; TANGLE [INPUT [OUTPUT]] -- extract code, return as string, optionally write output
(define (tangle . args)
  ; parse-line line -- extract prefix, call-name, suffix from line
  (define (parse-line line)
    (let* ((start (string-index line "<<" 0))
           (end (if start (string-index line ">>" (+ start 2)) #f)))
      (if (and start end)
          (values (substring line 0 start)
                  (substring line (+ start 2) end)
                  (substring line (+ end 2) (string-length line)))
          (values line "" ""))))
  ; named? par -- #t if named paragraph, #f otherwise
  (define (named? par)
    (if (null? par)
        #f
        (let* ((line (string-trim (car par)))
               (start (string-index line "<<" 0))
               (end (if start (string-index line ">>=" (+ start 2)) #f)))
          (and start end (zero? start) (= end (- (string-length line) 3))))))
  ; unnamed? par -- #t if unnamed paragraph, #f otherwise
  (define (unnamed? par)
    (if (null? par)
        #f
        (let ((line (string-trim (car par))))
          (and (not (string=? "" line))
               (or (char=? #\; (string-ref line 0))
                   (char=? #\( (string-ref line 0)))))))
  ; open-input port-or-file . ext -- open input file or port, optional extension
  (define (open-input port-or-file . ext)
    (cond ((input-port? port-or-file) port-or-file)
          ((not (string? port-or-file)) (error "error opening file"))
          ((file-exists? port-or-file)
            (open-input-file port-or-file))
          ((and (pair? ext)
                (file-exists? (string-append port-or-file (car ext))))
            (open-input-file (string-append port-or-file (car ext))))
          (else (error (string-append "can't open " port-or-file)))))
  ; open-output port-or-file . ext -- open output file or port, optional extension
  (define (open-output port-or-file . ext)
    (cond ((output-port? port-or-file) port-or-file)
          ((not (string? port-or-file)) (error "error opening file"))
          ((file-exists? port-or-file)
            (delete-file port-or-file)
            (open-output-file port-or-file))
          ((null? ext) (open-output-file port-or-file))
          ((file-exists? (string-append port-or-file (car ext)))
            (delete-file (string-append port-or-file (car ext)))
            (open-output-file (string-append port-or-file (car ext))))
          (else (open-output-file (string-append port-or-file (car ext))))))
  ; string-trim-left s -- remove whitespace from left end of string s
  (define (string-trim-left s)
    (cond ((string=? "" s) s)
          ((char-whitespace? (string-ref s 0))
            (string-trim-left (substring s 1 (string-length s))))
          (else s)))
  ; string-trim-right s -- remove whitespace from right end of string s
  (define (string-trim-right s)
    (cond ((string=? "" s) s)
          ((char-whitespace? (string-ref s (- (string-length s) 1)))
            (string-trim-right (substring s 0 (- (string-length s) 1))))
          (else s)))
  ; string-trim s -- remove whitespace from both ends of string s
  (define (string-trim s) (string-trim-left (string-trim-right s)))
  ; string-index search target start -- first appearance at or after start or #f
  (define (string-index search target start)
    (let ((search-len (string-length search))
          (target-len (string-length target)))
      (let loop ((k start))
        (cond ((< search-len (+ k target-len)) #f)
              ((string=? (substring search k (+ k target-len)) target) k)
              (else (loop (+ k 1)))))))
  ; read-line [port] -- read next line from port, return line or eof-object
  (define (read-line . port)
    (define (eat c p)
      (if (and (not (eof-object? (peek-char p))) (char=? (peek-char p) c))
          (read-char p)))
    (let ((p (if (null? port) (current-input-port) (car port))))
      (let loop ((c (read-char p)) (line '()))
        (cond ((eof-object? c) (if (null? line) c (list->string (reverse line))))
              ((char=? #\newline c) (eat #\return p) (list->string (reverse line)))
              ((char=? #\return c) (eat #\newline p) (list->string (reverse line)))
              (else (loop (read-char p) (cons c line)))))))
  ; read-par p -- next maximal set of non-blank lines from p, or eof-object
  (define (read-par p)
    (define (get-non-blank-line p)
      (let blank ((s (read-line p)))
        (if (and (not (eof-object? s)) (string=? "" s))
            (blank (read-line p))
            s)))
    (let par ((s (get-non-blank-line p)) (ls '()))
      (if (or (eof-object? s) (string=? "" s))
          (reverse ls)
          (par (read-line p) (cons s ls)))))
  ; tangl name dict indent output -- write tangled output
  (define (tangl name dict indent output)
    (let loop ((lines (cdr (assoc name dict))))
      (call-with-values
        (lambda () (parse-line (car lines)))
        (lambda (prefix call-name suffix)
          (display prefix output)
          (if (and (not (string=? "" call-name))
                   (assoc call-name dict))
              (tangl call-name
                     dict
                     (make-string (+ (string-length indent)
                                     (string-length prefix))
                                  #\space)
                     output))
          (cond ((not (string=? "" suffix)) (loop (cons suffix (cdr lines))))
                ((pair? (cdr lines))
                  (newline output)
                  (display indent output)
                  (loop (cdr lines))))))))
  ; build port -- build dictionary from port
  (define (build input)
    (let loop ((par (read-par input)) (dict '()))
      (cond ((null? par) dict)
            ((unnamed? par) (loop (read-par input) (add-dict "" dict par)))
            ((named? par) (loop (read-par input)
                                (add-dict (get-name par) dict (cdr par))))
            (else (loop (read-par input) dict)))))
  ; get-name par -- extract name from first line of par
  (define (get-name par)
    (let* ((line (car par))
           (start (string-index line "<<" 0))
           (end (string-index line ">>=" (+ start 2))))
      (substring line (+ start 2) end)))
  ; add-dict name dict lines -- append lines to name in dict, or create new name
  (define (add-dict name dict lines)
    (if (null? dict)
        (cons (cons name (dedent lines)) dict)
        (let loop ((item (car dict)) (unscanned (cdr dict)) (scanned '()))
          (cond ((string=? (car item) name)
                  (cons (append item (dedent lines))
                        (append unscanned (reverse scanned))))
                ((null? unscanned)
                  (cons (cons name (dedent lines)) (cons item (reverse scanned))))
                (else (loop (car unscanned) (cdr unscanned) (cons item scanned)))))))
  ; dedent ls -- remove common indentation from a list of strings
  (define (dedent ls)
    (define (all xs)
      (or (null? xs)
          (and (car xs)
               (all (cdr xs)))))
    (cond ((null? ls) ls)
          ((null? (cdr ls)) (list (string-trim-left (car ls))))
          ((and (< 1 (length ls))
           (all (map (lambda (s) (positive? (string-length s))) ls))
           (char-whitespace? (string-ref (car ls) 0))
           (apply char=? (map (lambda (s) (string-ref s 0)) ls)))
             (dedent (map (lambda (s) (substring s 1 (string-length s))) ls)))
          (else ls)))
  (let ((i (open-input (if (pair? args) (car args) (current-input-port)) ".lss"))
        (o (open-output-string)))
    (let ((dict (build i)))
      (if (pair? dict)
          (begin
            (tangl "" dict "" o)
            (close-input-port i)
            (let ((s (get-output-string o)))
              (close-output-port o)
              (if (and (pair? args) (pair? (cdr args)))
                  (let ((o (open-output (cadr args) ".ss")))
                    (display s o)
                    (close-output-port o)))
              s))))))
; WEAVE INPUT
(define (weave input)
  ; parse-line line -- extract prefix, call-name, suffix from line
  (define (parse-line line)
    (let* ((start (string-index line "<<" 0))
           (end (if start (string-index line ">>" (+ start 2)) #f)))
      (if (and start end)
          (values (substring line 0 start)
                  (substring line (+ start 2) end)
                  (substring line (+ end 2) (string-length line)))
          (values line "" ""))))
  ; named? par -- #t if named paragraph, #f otherwise
  (define (named? par)
    (if (null? par)
        #f
        (let* ((line (string-trim (car par)))
               (start (string-index line "<<" 0))
               (end (if start (string-index line ">>=" (+ start 2)) #f)))
          (and start end (zero? start) (= end (- (string-length line) 3))))))
  ; unnamed? par -- #t if unnamed paragraph, #f otherwise
  (define (unnamed? par)
    (if (null? par)
        #f
        (let ((line (string-trim (car par))))
          (and (not (string=? "" line))
               (or (char=? #\; (string-ref line 0))
                   (char=? #\( (string-ref line 0)))))))
  ; open-input port-or-file . ext -- open input file or port, optional extension
  (define (open-input port-or-file . ext)
    (cond ((input-port? port-or-file) port-or-file)
          ((not (string? port-or-file)) (error "error opening file"))
          ((file-exists? port-or-file)
            (open-input-file port-or-file))
          ((and (pair? ext)
                (file-exists? (string-append port-or-file (car ext))))
            (open-input-file (string-append port-or-file (car ext))))
          (else (error (string-append "can't open " port-or-file)))))
  ; open-output port-or-file . ext -- open output file or port, optional extension
  (define (open-output port-or-file . ext)
    (cond ((output-port? port-or-file) port-or-file)
          ((not (string? port-or-file)) (error "error opening file"))
          ((file-exists? port-or-file)
            (delete-file port-or-file)
            (open-output-file port-or-file))
          ((null? ext) (open-output-file port-or-file))
          ((file-exists? (string-append port-or-file (car ext)))
            (delete-file (string-append port-or-file (car ext)))
            (open-output-file (string-append port-or-file (car ext))))
          (else (open-output-file (string-append port-or-file (car ext))))))
  ; string-trim-left s -- remove whitespace from left end of string s
  (define (string-trim-left s)
    (cond ((string=? "" s) s)
          ((char-whitespace? (string-ref s 0))
            (string-trim-left (substring s 1 (string-length s))))
          (else s)))
  ; string-trim-right s -- remove whitespace from right end of string s
  (define (string-trim-right s)
    (cond ((string=? "" s) s)
          ((char-whitespace? (string-ref s (- (string-length s) 1)))
            (string-trim-right (substring s 0 (- (string-length s) 1))))
          (else s)))
  ; string-trim s -- remove whitespace from both ends of string s
  (define (string-trim s) (string-trim-left (string-trim-right s)))
  ; string-index search target start -- first appearance at or after start or #f
  (define (string-index search target start)
    (let ((search-len (string-length search))
          (target-len (string-length target)))
      (let loop ((k start))
        (cond ((< search-len (+ k target-len)) #f)
              ((string=? (substring search k (+ k target-len)) target) k)
              (else (loop (+ k 1)))))))
  ; read-line [port] -- read next line from port, return line or eof-object
  (define (read-line . port)
    (define (eat c p)
      (if (and (not (eof-object? (peek-char p))) (char=? (peek-char p) c))
          (read-char p)))
    (let ((p (if (null? port) (current-input-port) (car port))))
      (let loop ((c (read-char p)) (line '()))
        (cond ((eof-object? c) (if (null? line) c (list->string (reverse line))))
              ((char=? #\newline c) (eat #\return p) (list->string (reverse line)))
              ((char=? #\return c) (eat #\newline p) (list->string (reverse line)))
              (else (loop (read-char p) (cons c line)))))))
  ; read-par p -- next maximal set of non-blank lines from p, or eof-object
  (define (read-par p)
    (define (get-non-blank-line p)
      (let blank ((s (read-line p)))
        (if (and (not (eof-object? s)) (string=? "" s))
            (blank (read-line p))
            s)))
    (let par ((s (get-non-blank-line p)) (ls '()))
      (if (or (eof-object? s) (string=? "" s))
          (reverse ls)
          (par (read-line p) (cons s ls)))))
  ; weeve input output
  (define (weeve name input output)
    (display "<HTML><HEAD>" output) (newline output)
    (if (not (string=? "" name))
        (begin
          (display "<TITLE>" output) (display name output)
          (display "</TITLE>" output) (newline output)))
    (display "</HEAD><BODY><FONT FACE=\"ARIAL\">" output) (newline output)
    (let loop ((par (read-par input)))
      (if (pair? par)
          (begin (cond ((named? par) (write-named par output))
                       ((unnamed? par) (write-unnamed par output))
                       ((code? par) (write-code par output))
                       ((pair? par) (write-text par output)))
                 (loop (read-par input)))))
    (display "</FONT></BODY></HEAD></HTML>" output) (newline output))
  ; write-named par output
  (define (write-named par output)
    (display "<P><PRE>" output)
    (call-with-values
      (lambda () (parse-line (car par)))
      (lambda (prefix call-name suffix)
        (display "&laquo;" output)
        (display-text call-name output)
        (display "&raquo;" output)
        (display "&equiv;" output)))
    (display "</FONT><FONT FACE=\"COURIER\">" output) (newline output)
    (for-each (lambda (s) (display-code s output) (newline output)) (cdr par))
    (display "</PRE></FONT><FONT FACE=\"ARIAL\"</P>" output) (newline output))
  ; write-unnamed par output
  (define (write-unnamed par output)
    (display "<P><FONT FACE=\"COURIER\"><PRE>" output) (newline output)
    (for-each (lambda (s) (display-code s output) (newline output)) par)
    (display "</PRE></FONT><FONT FACE=\"ARIAL\"></P>" output) (newline output))
  ; write-code par output
  (define (write-code par output)
    (display "<P><FONT FACE=\"COURIER\"><PRE>" output) (newline output)
    (let loop ((par (cdr par)))
      (display "| " output) (display-code (car par) output) (newline output)
      (if (and (pair? (cdr par)) (pair? (cddr par))) (loop (cdr par))))
    (display "</PRE></FONT><FONT FACE=\"ARIAL\"></P>" output) (newline output))
  ; write-text par output
  (define (write-text par output)
    (display "<P>" output) (newline output)
    (for-each (lambda (s) (display-text s output) (newline output)) par)
    (display "</P>" output) (newline output))
  ; display-code line output
  (define (display-code line output)
    (let loop ((line line))
      (call-with-values
        (lambda () (parse-line line))
        (lambda (prefix call-name suffix)
          (display (quote-html prefix) output)
          (if (not (string=? "" call-name))
              (begin (display "</FONT><FONT FACE=\"ARIAL\">&laquo;" output)
                     (display-text call-name output)
                     (display "&raquo;</FONT><FONT FACE=\"COURIER\">" output)))
          (if (not (string=? "" suffix)) (loop suffix))))))
  ; display-text line output
  (define (display-text line output)
    (let loop ((line line))
      (let* ((start (string-index line "[[" 0))
             (end (if start (string-index line "]]" (+ start 2)) #f)))
        (if (and start end)
            (begin (display (substring line 0 start) output)
                   (display "</FONT><FONT FACE=\"COURIER\">" output)
                   (display (quote-html (substring line (+ start 2) end)) output)
                   (display "</FONT><FONT FACE=\"ARIAL\">" output)
                   (loop (substring line (+ end 2) (string-length line))))
            (display line output)))))
  ; quote-html -- quote special html characters <, >, and &
  (define (quote-html str)
    (let* ((s1 (string-replace str "&" "&amp;"))
           (s2 (string-replace s1 "<" "&lt;"))
           (s3 (string-replace s2 ">" "&gt;")))
      s3))
  ; code? par -- #t if code paragraph (for display), #f otherwise
  (define (code? par)
    (and (string=? "[[" (car par))
         (string=? "]]" (car (reverse par)))))
  ; base-name file-name suffix -- delete suffix from file-name if it matches
  (define (base-name file-name suffix)
    (let ((len-file (string-length file-name))
          (len-suffix (string-length suffix)))
      (if (string=? (substring file-name (- len-file len-suffix) len-file) suffix)
          (substring file-name 0 (- len-file len-suffix))
          file-name)))
  ; string-replace target search replace
  (define (string-replace target search replace)
    (let ((search-len (string-length search))
          (target-len (string-length target)))
      (let loop ((k 0))
        (cond ((< target-len (+ k search-len)) target)
              ((string=? (substring target k (+ k search-len)) search)
                (string-append
                   (substring target 0 k)
                   replace
                   (string-replace
                     (substring target (+ k search-len) target-len)
                     search
                     replace)))
              (else (loop (+ k 1)))))))
  (let ((i (open-input input ".lss"))
        (o (open-output (base-name input ".lss") ".html")))
    (weeve (base-name input ".lss") i o)
    (close-input-port i)
    (close-output-port o)))
; LLOAD FILE-NAME
(define (lload file-name)
  (let* ((ss (tangle file-name))
         (i (open-input-string ss)))
    (let loop ((obj (read i)))
      (if (eof-object? obj)
          (close-input-port i)
          (begin (eval obj (interaction-environment))
                 (loop (read i)))))))