#!/usr/bin/env newlisp

;; @module markdown-interactive
;; @author cormullion 
;; @version 0.0.2 of 2007-12-02 21:35:40
;; This newLISP-GS application provides a way of testing the Markdown translator.
;; You type Markdown-formatted text in one pane, and the HTML appears in the other
;; two panes unrendered and rendered. This file includes a version of markdown.lsp.
;; Note that this version of markdown generates XHTML, which doesn't always display well
;; in the newLISP-GS HTML pane.

(load "/usr/share/newlisp/guiserver.lsp")        ; unix
;(load "c:/Program Files/newlisp/guiserver.lsp") ; windows

(gs:init)
(gs:frame 'Markdown-interactive 100 100 900 500 "Markdown-interactive")
(gs:panel 'MainPanel)
  (gs:set-grid-layout 'MainPanel 1 3)
  (gs:text-pane 'string-input 'textfield-handler "text/plain")
  (gs:text-area 'text-output 'gs:no-action)
  (gs:text-pane 'html-output 'gs:no-action "text/html")

    (gs:set-editable 'text-output nil)
    (gs:set-editable 'html-output nil)
 
  (gs:add-to 'MainPanel 'string-input 'text-output 'html-output)
  (gs:add-to 'Markdown-interactive 'MainPanel )

(set 'html-header [text]
<style>
pre, code
{
	font-family: Monaco, 'Andale Mono', 
        'Lucida Console', monospace;
  font-size: 12pt;
  /* http://users.tkk.fi/~tkarvine/pre-wrap-css3-mozilla-opera-ie.html */
	/* css-3 */
	/* Mozilla, since 1999 */
	/* Opera 4-6 */
	word-wrap: break-word;

}

pre	.nl
{
	color: #220088;
	background: #ffeeff;
}

/* nil and undefined */
pre	.t
{
	color: #222222;
	font-weight: bold;
	background: #efefef;
}

/* true */
pre	.i
{
	color: #888811;
	background: #eeeeee;
}

/* int */
pre	.f
{
	color: #000000;
	background: #eeeedd;
}

/* float */
pre	.s
{
	color: #444444;
	background: #ddeedd;
}

/* string */
pre	.sy
{
	color: #0000dd;
	background: #ddddaa;
}

/* symbol */
pre	.ct
{
	color: #001188;
	background: #eeeedd;
	font-weight: bold;
}

/* context */
pre	.p
{
	color: #880000;
	background: #ffffff;
}

/* primitive */
pre	.p1
{
	color: #333333;
	background: #555555;
}

/* ? */
pre	.p2
{
	color: #333333;
	background: #555555;
}

/* ? */
pre	.q
{
	color: #000000;
	background: #ffffff;
}

/* quote */
pre	.l
{
	color: #000088;
	background: #ffffff;
}

/* list */
pre	.la
{
	color: #008888;
	background: #ffffee;
}

/* lambda */
pre	.ma
{
	color: #882222;
	background: #eeffdd;
}

/* macro */
pre	.a
{
	color: #333333;
	background: #dddddd;
}

/* array */
pre	.o
{
	color: #ffff00;
	background: #333333;
}

/* other */
pre	.c
{
	color: #888888;
	font-family: serif;
}

/* comment */
pre	.pr { color: #888888; }

/* parenthesis */


</style>
[/text]
)

(set 'sentinel true)

(define (run-markdown txt)
; don't run unless we can
  (let (result)
    (if sentinel
      (begin
        (set 'sentinel nil)
        (set 'result (markdown txt))
        (set 'sentinel true)
        result)
      (set 'result {}))))

(define (textfield-handler id key dot mark)
  (and
    (!= key 65535) ; not cursor
    sentinel
    (gs:get-text id 'gettextcallback-handler)))

(define (gettextcallback-handler id text)
  (and
     text
     (= id "MAIN:string-input")
     (set 'strng (base64-dec text))
     (set 'start (time-of-day))
     (set 'result (run-markdown strng))
     (gs:set-text 'text-output (string result "\n\n\n took " (- (time-of-day) start) {ms}))
     (gs:set-text 'html-output (string html-header result))))

(gs:set-text 'string-input [text]## Markdown-Interactive

For more information about _Markdown_, visit John Gruber's [Daring Fireball](http://www.daringfireball.net "Daring Fireball") site.
[/text])

; the following three contexts have been included here for convenience but they're maintained 
; and updated separately ...

(context 'Tokenize)

(define (Tokenize:Tokenize txt)
;; tokenize the source in txt
;; Based on newLISP guru Fanda's code to scan source and split according to category:
;; Mode: 0 - code
;;       1 - ""
;;       2 - {}
;;       3 - [text][text]
;;       4 - ; or #
   (let (i 0 ch "" mode 0 txt-length 0 code-starts true n-brackets 0 result '() token-list '()
         raw-tokens '() source-string "" )
      (if (not txt) (exit))
      ; beginning of text
      (set 'ch 
         (txt 0)) 
      (if (= ch {"}) 
         (set 'mode 1) 
         (= ch "{" ) 
         (set 'mode 2) 
         (= "[text]"  
            (0 6 txt)) 
         (set 'mode 3) 
         (or 
            (= ch ";" ) 
            (= ch "#" )) 
         (set 'mode 4) 
         (set 'mode 0))
    (push (list mode 0) result -1)
    ;; skip char(s)
    (if (= mode 3)
      (inc 'i 6)
      (inc 'i))
      
      ;; main processing loop
      (set 'txt-length (length txt))
      (while 
         (< i txt-length) 
         (set 'ch 
            (txt i))
         (case mode 
            (0 (begin
                 (if
                  (= ch {"}) 
                      (begin 
                           (set 'mode 1)
                           (push (list mode i) result -1))
                  (= ch "{") 
                      (begin 
                         (inc 'n-brackets)
                         (set 'mode 2)
                         (push (list mode i) result -1)) 
                  (= "[text]"  
                     (i 6 txt)) 
                      (begin 
                         (set 'mode 3)
                         (push (list mode i) result -1) 
                         (inc 'i 5)) 
                  (or 
                     (= ch ";" ) 
                     (= ch "#" )) 
                        (begin 
                           (set 'mode 4) 
                           (push (list mode i) result -1)) 
                  (if code-starts
                     (begin 
                        (set 'code-starts nil) 
                        (push (list mode i) result -1))))
                  ))
            (1 (if (= ch {\})
                      (inc 'i) 
                   (= ch {"})
                      (begin
                         ; don't mark the end...
                         ; (push (list mode i) result -1) 
                         (set 'mode 0) 
                         (set 'code-starts true)))) 
            (2 (if (= ch "{")  
                     (inc 'n-brackets) 
                  (= ch "}") 
                  (begin 
                     (dec 'n-brackets) 
                     (if (= 0 n-brackets) 
                        (begin 
                           ;(push (list mode i) result -1) 
                           (set 'mode 0) 
                           (set 'code-starts true)))))) 
            (3 (if (= "[/text]"  
                     (i 7 txt)) 
                  (begin 
                     (inc 'i 6) 
                     ; (push (list mode i) result -1) 
                     (set 'mode 0) 
                     (set 'code-starts true)))) 
            (4 (if (= ch "\n" ) 
                  (begin 
                     ; return "\n" into code  
                     (push (list mode i) result -1) 
                     (dec 'i)
                     (set 'mode 0) 
                     (set 'code-starts true))))) 
         (inc 'i))
      ; end the code according to the current mode  
      (push (list mode (length txt)) result -1)
   ; convert to list of tokens 
   (for (p 0 (- (length result) 2))
      (set 'type  (first (result p)))
      (set 'start (last  (result p)))
      (set 'end   (last  (result (+ p 1))))
      (set 'source-string 
            (slice txt start (- end start))) 
      (cond 
        ((= start end)
           (push (list "white-space" source-string) token-list -1))
        ((= type 0)
           ; replace : with colon, otherwise it will be 
           ; stripped out by parse
           (replace ":" source-string " colon " )
           ; bad code will not parse!
           (set 'raw-tokens (parse source-string))
           (dolist (tkn raw-tokens)
              (cond 
                 ((= tkn "(" ) 
                    (push (list "left-paren" tkn) token-list -1)) 
                 ((= tkn ")" ) 
                    (push (list "right-paren" tkn) token-list -1)) 
                 ((= tkn "colon" ) 
                    (push (list "code"  ":" ) token-list -1)) 
                 (true 
                    (push (list "code" tkn) token-list -1))))) 
        ((= type 1) 
              (push (list "quoted-string" source-string) token-list -1)) 
        ((= type 2) 
              (push (list "braced-string" source-string) token-list -1)) 
        ((= type 3) 
             (push (list "bracketed-string" source-string) token-list -1)) 
        ((= type 4) 
             (push (list "comment" source-string) token-list -1)))
         ) 
    token-list))


(context 'Pretty)

(set 'depth 0 'tab-width 4 'output-buffer {} 'html-format true)

(define (format-code-element k) 
; return list of three strings: startmarkup, element, end markup
 (let ((result '())
    (code-element-string k)
    ) 
  (if (or 
      (= k "fn" ) 
      (= k "lambda")
      (= k "lambda-macro")) 
    (set 'result (list  {<span class="la">}  code-element-string {</span>}))  
    (cond
     ((= k "'")
           (set 'result (list {<span class="q">} code-element-string {</span>})))
     (true
         (set 'type-number (& 15 (nth 1 (dump (eval-string k)))))     
         (case type-number
           (0   (set 'result (list  {<span class="nl">} code-element-string {</span>} ))) ; nil
           (1   (set 'result (list  {<span class="t">}  code-element-string {</span>} ))) ; true
           (2   (set 'result (list  {<span class="i">}  code-element-string {</span>} ))) ; int
           (3   (set 'result (list  {<span class="f">}  code-element-string {</span>} ))) ; float
           (4   (set 'result (list  {<span class="s">}  code-element-string {</span>} ))) ; string
           (5   (set 'result (list  {<span class="sy">} code-element-string {</span>} ))) ; sym
           (6   (set 'result (list  {<span class="ct">} code-element-string {</span>} ))) ; ctx
           (7   (set 'result (list  {<span class="p">}  code-element-string {</span>} ))) ; pri
           (8   (set 'result (list  {<span class="p1">}  code-element-string {</span>}))) ; pri
           (9   (set 'result (list  {<span class="p2">}  code-element-string {</span>}))) ; pri
           (10  (set 'result (list  {<span class="q">}  code-element-string {</span>} ))) ; quote
           (11  (set 'result (list  {<span class="l">}  code-element-string {</span>} ))) ; list
           (12  (set 'result (list  {<span class="la">} code-element-string {</span>} ))) ; lambda
           (13  (set 'result (list  {<span class="ma">} code-element-string {</span>} ))) ; macro
           (14  (set 'result (list  {<span class="a">}  code-element-string {</span>} ))) ; array
           (true (set 'result (list {<span class="o">} code-element-string {</span>} )))))))
  result))

(define (tab)
  (dup { } (- (* depth tab-width) 1)))

(define (escape-html txt)
 (if txt
  (begin
   (replace {&} txt {&amp;} 0)
   (replace {<} txt {&lt;} 0)
   (replace {>} txt {&gt;} 0)))
 txt)

(define (output start-markup s end-markup) 
; push the string into a buffer
  (if html-format
     (set 's (string start-markup (escape-html s) end-markup))
     (set 's (string   s )))
  (push s output-buffer -1))
   
(define (pretty-output list-of-tokens (use-CSS true))
  (set 'depth 0 'tab-width 4 'output-buffer {} 'html-format use-CSS)
  (dolist (t list-of-tokens)   
   (set 'type 
    (first t)) 
   (set 'data 
    (last t)) 
   (set 'previous-type 
    (first 
      (list-of-tokens 
       (- $idx 1)))) 
   (set 'previous-data 
    (last 
      (list-of-tokens 
       (- $idx 1)))) 
   (cond 
    ((= type "right-paren")
      (if (and (= previous-type "comment") (>= depth 1))
       (output "" "" ""))
      ; add right paren to stack of previous
      (if (and (= previous-type "right-paren") (>= depth 1))
       (output {<span class="pr">} {)} {</span>})
       (output {<span class="pr">} {)} {</span>}))
      (if (<= depth 1) 
       (output "" "\n" "") 
       (output "" "" "")) 
      (if (<= depth 0)
        (output "" "?" ""))
      (dec 'depth)
      ) 
    ((= type "left-paren" )   
      ; no newline/indent before left paren ...
      (if (not 
         (or 
           ; not after some functions  
           (find previous-data '("define" "let" "letn" "set" "lambda" "fn" "push" "'" "if" "(" "dolist" "unless" "for" "while" "dotree")) 
           ; not if previous line was a comment
           (= previous-type "comment")
           (= previous-type "white-space")
           ; and not if we're following a very short function/operator
           (and 
                (<= (length previous-data) 2) 
                (= previous-type "code")))
          ; newline and indent...
           (begin
             (output "" "\n" "")
             (output "" (tab) ""))))
      ; no space if following left paren or ' or comment
      (if (or 
             (= previous-type "left-paren") 
             (= previous-data "'" )
             (= previous-type "comment")
             (= depth 0))         
         (output "" "" "")
         (output "" " " ""))

      (output (string {<span class="pr">}) {(} {</span>}) 
      (inc 'depth))
      
    ((and (= type "comment") (!= data ""))
        ; newline before comment unless the shebang line
        (if (not 
            (or (starts-with data {#!/usr/bin})
                (= previous-type "comment")
                (= previous-type "white-space")))
            (output "" "\n" ""))
        
        (if (starts-with data ";;" )
         ; two or more semicolons, so start at beginning of line 
         (begin 
             (output {<span class="c">} data (string {</span>}))
             (output {} "\n" {}))
         ; other comments start indented at current level
         (begin
           ; indent to current level
             (if (not (= previous-type "white-space"))
                 (output ""  (tab)  ""))
           ; output the comment
           (output {<span class="c">} data (string {</span>}))
           ; start the next line, and indent to current level again
           ; ready for next
           (output "" (string "\n" (tab)) "")
           )))
         
    ((= type "code" ) 
      (cond 
       ((= data "'")
         (output "" " " "")
         (apply output (format-code-element data )))
       ((= data ":")
         (apply output (format-code-element data)))        
       ((or 
            (= previous-type "left-paren" ) 
            (= previous-data ":" ) 
            (= previous-data "'" )) 
         (output "" "" "")
         (apply output (format-code-element data)))      
       (true 
           (output "" " " "")
           (apply output (format-code-element data )))))

    ((= type "braced-string")
      (if (not (= previous-type "left-paren")) 
              (output "" " " ""))
      (apply output (list  (string {<span class="s">}) data (string {</span>}))))
       
    ((= type "quoted-string")
      ; space before the string/double quote char
      (if (not (= previous-type "left-paren")) 
              (output "" " " ""))
      (apply output  (list (string {<span class="s">}) data (string {</span>})))) 
      
    ((= type "bracketed-string" ) 
      ; space before
      (if (not (= previous-type "left-paren")) 
              (output "" " " ""))
      (apply output (list (string {<span class="s">}) data {</span>})))))
   
   output-buffer
   )

; eof

(context 'markdown)

(define (markdown:markdown txt)
  (initialize)
  (unescape-special-chars (block-transforms (strip-link-definitions (protect (cleanup txt))))))

; initialize

(define (initialize)
  (set '*escape-chars* [text]\`*_{}[]()>#+-.![/text])     
  (set '*escape-pairs*   '(
    ([text]\\\\[/text] [text]\\[/text])
    ([text]\\`[/text]  [text]`[/text])
    ([text]\\\*[/text] [text]*[/text]) 
    ([text]\\_[/text]  [text]_[/text])
    ([text]\\\{[/text] [text]{[/text])
    ([text]\\\}[/text] [text]}[/text])
    ([text]\\\[[/text] [text][[/text])
    ([text]\\\][/text] [text]][/text])
    ([text]\\\([/text] [text]([/text])
    ([text]\\\)[/text] [text])[/text])
    ([text]\\>[/text]  [text]>[/text])
    ([text]\\\#[/text] [text]#[/text])
    ([text]\\\+[/text] [text]+[/text])
    ([text]\\\-[/text] [text]-[/text])
    ([text]\\\.[/text] [text].[/text])
    ([text]\\![/text]  [text]![/text])
    ))
  (set '*hashed-html-blocks* '())
  (build-escape-table)
  (set '*list-level* 0))

(define (block-transforms txt)
   (form-paragraphs 
    (protect 
     (block-quotes 
      (code-blocks 
       (lists 
        (horizontal-rules 
         (headers txt))))))))

(define (span-transforms txt)
  (line-breaks 
   (emphasis 
    (amps-and-angles 
     (auto-links 
      (anchors 
       (images 
        (escape-special-chars 
         (escape-special-chars-within-tag-attributes 
          (code-spans txt))))))))))

(define (hash s)
  (base64-enc (uuid)))

(define (build-escape-table)
  (set '*escape-table* '())
  (dolist (c (explode *escape-chars*))
    (push (list c (hash c)) *escape-table*)))

(define (tokenize-html xhtml)
; return list of tag/text portions of xhtml text
  (letn (
       (tag-match [text]((?s:<!(-- .*? -- \s*)+>)|
(?s:<\?.*?\?>)|
(?:<[a-z/!$](?:[^<>]|
(?:<[a-z/!$](?:[^<>]|
(?:<[a-z/!$](?:[^<>]|
(?:<[a-z/!$](?:[^<>]|
(?:<[a-z/!$](?:[^<>]|
(?:<[a-z/!$](?:[^<>])*>))*>))*>))*>))*>))*>))[/text]) ; yeah, well...
      (str xhtml)
      (len (length str))
      (pos 0)
      (tokens '())
      )
 (while (set 'tag-start (find tag-match str 8))
    (if (< pos tag-start)
       (push (list text (slice str pos (- tag-start pos))) tokens -1))
    (push (list tag $0) tokens -1)
    (set 'str (slice str (+ tag-start (length $0))))
    (set 'pos 0))
 ; leftovers
  (if (< pos len)
     (push (list (quote text) (slice str pos (- len pos))) tokens -1))
  tokens)
)

(define (escape-special-chars-within-tag-attributes txt)
  (let ((temp (tokenize-html txt))
        (new-text {})
       )
    (dolist (pair temp)
         (if (= (first pair) 'tag)
            ; 'tag
            (begin
              (set 'new-text (replace {\\} (last pair) (lookup {\\} *escape-table*) 0))
              (replace [text](?<=.)</?code>(?=.)[/text] new-text (lookup {`} *escape-table*) 0)
              (replace {\*} new-text (lookup {*} *escape-table*) 0)
              (replace {_} new-text (lookup {_} *escape-table*) 0)
            )
            ; 'text
            (set 'new-text  (last pair))
         )
       (nth-set (temp $idx) (list (first pair) new-text)))
  (join (map last temp)) ; return as text
  )
)

(define (escape-special-chars txt )
 ; replaces characters in tags and text tokens
  (let ((temp (tokenize-html txt))
        (new-text {})
       )
    (dolist (pair temp)
       (if (= (first pair) 'tag)
          ; 'tag
          (begin
            (set 'new-text (replace {\\} (last pair) (lookup {\\} *escape-table*) 0))
            (replace [text](?<=.)</?code>(?=.)[/text] new-text (lookup {`} *escape-table*) 0)
            (replace {\*} new-text (lookup {*} *escape-table*) 0)
            (replace {_} new-text (lookup {_} *escape-table*) 0)
            )
          ; 'text
          (begin
            (set 'new-text (encode-backslash-escapes (last pair)))))
       (nth-set (temp $idx) (list (first pair) new-text)))
  (join (map last temp)) ; return as text
  )
)

(define (encode-backslash-escapes t)
   (dolist (pair *escape-pairs*)
      (replace (first pair) t (lookup (last pair) *escape-table*) 14))
 t)

(define (encode-code s)
 ; encode/escape certain characters inside Markdown code runs
  (replace {&}  s   "&amp;" 0)
  (replace {<}  s   "&lt;" 0)
  (replace {>}  s   "&gt;" 0)
  (replace {\*} s   (lookup {*} *escape-table*) 0)
  (replace {_}  s   (lookup {_} *escape-table*) 0)
  (replace "{"  s   (lookup "{" *escape-table*) 0)
  (replace {\[} s   (lookup {[} *escape-table*) 0)
  (replace {\]} s   (lookup {]} *escape-table*) 0)
  (replace {\\} s   (lookup {\\} *escape-table*) 0)
  s)

(define (code-spans s)
  (replace  
    {(?<!\\)(`+)(.+?)(?<!`)\1(?!`)} 
    s 
    (string {<code>} (encode-code (trim $2)) {</code>}) 
    2
    )
  s)

(define (encode-alt s)
  (replace {&} s "&amp;" 0)
  (replace {"} s "&quot;" 0)
  s)

(define (images txt)
 (let ((alt-text {})
       (url {} )
       (title {})
       (ref-regex {(!\[(.*?)\][ ]?(?:\n[ ]*)?\[(.*?)\])})
       (inline-regex {(!\[(.*?)\]\([ \t]*<?(\S+?)>?[ \t]*((['"])(.*?)\5[ \t]*)?\))})
       (whole-match {})
       (result {})
       (id-ref {})
       (url {})
       )
  ;  reference links ![alt text][id]
  (replace 
    ref-regex 
    txt 
    (begin
       (set 'whole-match $1 'alt-text $2 'id-ref $3)       
       (if alt-text
             (replace {"} alt-text {&quot;} 0))
       (if (empty? id-ref)
            (set 'id-ref (lower-case alt-text)))
       (if (lookup id-ref *link-database*)
           (set 'url (first (lookup id-ref *link-database*)))
           (set 'url nil))
       (if url
           (begin 
              (replace {\*} url (lookup {*} *escape-table*) 0)
              (replace {_}  url (lookup {_} *escape-table*) 0) 
            ))             
       (if (last (lookup id-ref *link-database*))
            ; title
           (begin
             (set 'title (last (lookup id-ref *link-database*)))
             (replace {"}  title {&quot;} 0)
             (replace {\*} title (lookup {*} *escape-table*) 0)
             (replace {_}  title (lookup {_} *escape-table*) 0))
           ; no title
           (set 'title {})
           )       
       (if url
        (set 'result (string 
          {<img src="} 
          (trim url) 
          {" alt="} 
          alt-text {" }
          (if (not (empty? title)) 
               (string { title="} title {"}) {})
          { />}))
        (set 'result whole-match))
     )
     0
   )
   ; inline image refs:  ![alt text](url "optional title")
    (replace 
      inline-regex 
      txt 
      (begin
        (set 'whole-match $1)
        (set 'alt-text $2)
        (set 'url $3)
        (set 'title $6)
        (if alt-text
             (replace {"} alt-text {&quot;} 0)
             (set 'alt-text {}))          
        (if  title 
             (begin 
               (replace {"}  title {&quot;} 0)
               (replace {\*} title (lookup {*} *escape-table*) 0)
               (replace {_}  title (lookup {_} *escape-table*) 0))
             (set 'title {}))           
        (replace {\*} url (lookup {*} *escape-table*) 0)
        (replace {_} url (lookup {_} *escape-table*) 0)
        (string 
           {<img src="} 
           (trim url) 
           {" alt="} 
           alt-text {" }
           (if title (string {title="} title {"}) {}) { />})
        )
        0
     )
    ; empty ones are possible
    (set '$1 {})
    (replace {!\[(.*?)\]\([ \t]*\)} 
     txt 
     (string {<img src="" alt="} $1 {" title="" />})
      0
     ) 
     
   )
 txt)

(define (make-anchor link-text id-ref )
; Link defs are in the form: ^[id]: url "optional title"
; stored in link db list  as (id (url title))
; params are text to be linked and the id of the link in the db
; eg bar 1 for [bar][1]
   (let (
        (title {})
        (id id-ref)
        (url nil)
        )
   (if link-text
       (begin
          (replace {"} link-text {&quot;} 0)
          (replace {\n} link-text { } 0)
          (replace {[ ]?\n} link-text { } 0)
          ))   
    (if (null? id ) (set 'id  (lower-case link-text)))
    (if (not (nil? (lookup id *link-database*)))
       (begin
         (set 'url (first (lookup id  *link-database*)))
         (replace {\*} url (lookup {*} *escape-table*) 0)
         (replace {_}  url (lookup {_} *escape-table*) 0)
         (if (set 'title (last (lookup id  *link-database*)))
           (begin 
                 (replace {"}  title {&quot;} 0)
                 (replace {\*} title (lookup {*} *escape-table*) 0)
                 (replace {_}  title (lookup {_} *escape-table*) 0))
           (set 'title {})))
       (set 'url nil))
   (if url
    (string {<a href="} 
            (trim url) 
            {"}
            (if (not (= title {}))
                (string { title="} (trim title) {"}) {})
            {>} link-text {</a>})
    (string {[} link-text {][} id-ref {]}))
   )
)

(define (anchors txt)
  (letn ((nested-brackets {(?>[^\[\]]+)*})
         (ref-link-regex (string {(\[(} nested-brackets {)\][ ]?(?:\n[ ]*)?\[(.*?)\])}))
         (inline-regex {(\[(.*?)\]\([ ]*<?(.*?\)?)>?[ ]*((['"])(.*?)\5[ \t]*)?\))})
         (link-text {})
         (url {})
         (title {})
        )         
  ; reference-style links: [link text] [id]
  (set '$1 {} '$2 {} '$3 {} '$4 {} '$5 {} '$6 {})    ; i still don't think I should have to do this...
  (replace ref-link-regex txt (make-anchor $2 $3) 8) ; $2 is link text, $3 is id
  ; inline links: [link text](url "optional title")
  (set '$1 {} '$2 {} '$3 {} '$4 {} '$5 {} '$6 {})
  (replace 
     inline-regex 
     txt 
    (begin
      (set 'link-text $2)
      (set 'url $3)
      (set 'title $6)
      (if link-text (replace {"} link-text {&quot;} 0))          
      (if title 
           (begin 
             (replace {"}  title {&quot;} 0)
             (replace {\*} title (lookup {*} *escape-table*) 0)
             (replace {_}  title  (lookup {_} *escape-table*) 0))
           (set 'title {}))           
      (replace {\*} url (lookup {*} *escape-table*) 0)
      (replace {_}  url (lookup {_} *escape-table*) 0)
      (replace {^<(.*)>$} url $1 0)
      (string 
         {<a href="} 
         (trim url)
         {"}
         (if (not (= title {})) 
                 (string { title="} (trim title) {"}) 
                 {})
         {>} link-text {</a>}
         ))
     8
   ) ; replace
 )
 txt)

(define (auto-links txt)
 (replace 
    [text]<((https?|ftp):[^'">\s]+)>[/text] 
    txt 
    (string {<a href="} $1 {">} $1 {</a>})  
    0
 )
  ; to-do: email ...
  txt)

(define (amps-and-angles txt)
; Smart processing for ampersands and angle brackets
  (replace 
    [text]&(?!\#?[xX]?(?:[0-9a-fA-F]+|\w+);)[/text]
    txt
    {&amp;}
    10
  )
  (replace 
    [text]<(?![a-z/?\$!])[/text]
    txt
    {&lt;}
    10
  )
  txt)

(define (emphasis txt)
  ; italics/bold: strong first
  (replace 
    [text] (\*\*|__) (?=\S) (.+?[*_]*) (?<=\S) \1 [/text]
    txt
    (string {<strong>} $2 {</strong>})
    8   
  )
  (replace 
    [text] (\*|_) (?=\S) (.+?) (?<=\S) \1 [/text]
    txt
    (string {<em>} $2 {</em>})
    8  
  )
  txt)

(define (line-breaks txt)
  ; handles line break markers
  (replace " {2,}\n" txt " <br/>\n" 0)
  txt)

(define (cleanup txt)
  ; cleanup the text by normalizing some possible variations
  (replace "\r\n|\r" txt "\n" 0)      ; standardize line ends
  (push "\n\n" txt -1)                ; end with two returns
  (set 'txt (detab txt))              ; convert tabs to spaces
  (replace "\n[ \t]+\n" txt "\n\n" 0) ; lines with only spaces and tabs
  txt)

(define (protect txt)
 ; protect or "hash html blocks"
 (let ((nested-block-regex  [text](^<(p|div|h[1-6]|blockquote|pre|table|dl|ol|ul|script|noscript|form|fieldset|iframe|math|ins|del)\b(.*\n)*?</\2>[ \t]*(?=\n+|\Z))[/text])
       (liberal-tag-regex [text](^<(p|div|h[1-6]|blockquote|pre|table|dl|ol|ul|script|noscript|form|fieldset|iframe|math)\b(.*\n)*?.*</\2>[ \t]*(?=\n+|\Z))[/text])
       (hr-regex  [text](?:(?<=\n\n)|\A\n?)([ ]{0,3}<(hr)\b([^<>])*?/?>[ \t]*(?=\n{2,}|\Z))[/text])
       (html-comment-regex [text](?:(?<=\n\n)|\A\n?)([ ]{0,3}(?s:<!(--.*?--\s*)+>)[ \t]*(?=\n{2,}|\Z))[/text])
      )
   (dolist (rgx (list nested-block-regex liberal-tag-regex hr-regex html-comment-regex))
     (replace 
        rgx 
        txt
        (begin
          (set 'key (hash $1))
          (push (list key $1 ) *hashed-html-blocks* -1)
          (string "\n\n" key "\n\n"))
        2)
    )
  )
 txt)

(define (unescape-special-chars t)
 ; Swap back in all the special characters we've hidden.
  (dolist (pair *escape-table*)
    (replace (last pair) t (first pair) 10)
    )
  t)

(define (strip-link-definitions txt)
 ; strip link definitions from the text and store them
 ; Link defs are in the form: ^[id]: url "optional title"
 ; stored in link db list  as (id (url title))
  (let ((link-db '())
        (url {})
        (id {})
        (title {})
       )
  (replace 
    [text]^[ ]{0,3}\[(.+)\]:[ \t]*\n?[ \t]*<?(\S+?)>?[ \t]*\n?[ \t]*(?:(?<=\s)["(](.+?)[")][ \t]*)?(?:\n+|\Z)[/text]
    txt 
    (begin 
      (set 'id (lower-case $1) 'url (amps-and-angles $2) 'title $3)
      (if title (replace {"} title {&quot;} 0))
      (push (list id (list url title)) link-db)
      (set '$3 {}) ; necessary?
      (string {}) ; remove from text
      ) 
    10)
  (set '*link-database* link-db)
  txt
  )
)

(define (horizontal-rules txt)
 (replace 
   [text]^[ ]{0,2}([ ]?\*[ ]?){3,}[ \t]*$[/text]
    txt
    "\n<hr />"
    14)  
  (replace 
    [text]^[ ]{0,2}([ ]? -[ ]?){3,}[ \t]*$[/text]
    txt
    "\n<hr />"
    14)  
  (replace 
    [text]^[ ]{0,2}([ ]? _[ ]?){3,}[ \t]*$[/text]
    txt
    "\n<hr />"
    14)
 txt)

(define (headers txt)
  ; setext headers
 (let ((level 1)
      )
 (replace 
   [text]^(.+)[ \t]*\n=+[ \t]*\n+[/text]
   txt 
   (string "<h1>" (span-transforms $1) "</h1>\n\n")
   2)  
  
 (replace 
   [text]^(.+)[ \t]*\n-+[ \t]*\n+[/text]
   txt 
   (string "<h2>" (span-transforms $1) "</h2>\n\n")
   2) 
   ; atx headers
 (replace 
   [text]^(\#{1,6})\s*(.+?)[ ]*\#*(\n+)[/text]
   txt 
   (begin
    (set 'level (length $1))
    (string "<h" level ">" (span-transforms $2) "</h" level ">\n\n")
    )
   2)
 )
 txt)

(define (lists txt)
 (letn ((marker-ul {[*+-]})
        (marker-ol {\d+[.]})
        (marker-any (string {(?:} marker-ul {|} marker-ol {)}))
        (whole-list-regex (string [text](([ ]{0,3}([/text] marker-any [text])[ \t]+)(?s:.+?)(\z|\n{2,}(?=\S)(?![ \t]*[/text] marker-any [text][ \t]+)))[/text]))
        (my-list {})
        (list-type {})
        (my-result {})
        )
   (replace 
      (if (> *list-level* 0)
          (string {^} whole-list-regex) 
          (string {(?:(?<=\n\n)|\A\n?)} whole-list-regex))
      txt
      (begin
         (set 'my-list $1)
         (if (find $3 marker-ul) 
            (set 'list-type "ul" 'marker-type marker-ul) 
            (set 'list-type "ol" 'marker-type marker-ol))
         (replace [text]\n{2,}[/text] my-list "\n\n\n" 0)
         (set 'my-result (process-list-items my-list marker-any))
         (replace {\s+$} my-result {} 0)
         (string {<} list-type {>} "\n" my-result "\n" {</} list-type {>} "\n"))
      10 ; must be multiline
      )   
 )
 txt
)

(define (process-list-items list-text marker-any)    
  (let ((list-regex (string [text](\n)?(^[ \t]*)([/text] marker-any [text])[ \t]+((?s:.+?)(\n{1,2}))(?=\n*(\z|\2([/text] marker-any [text])[ \t]+))[/text]))
        (item {})
        (leading-line {})
        (leading-space {})
        (result {})
       )
  (inc '*list-level*)
  (replace [text]\n{2,}\z[/text] list-text "\n" 0)
  (set '$1 {} '$2 {} '$3 {} '$4 {} '$5 {})
  (replace 
    list-regex
    list-text
    (begin
      (set 'item $4)
      (set 'leading-line $1)
      (set 'leading-space $2)
      (if (or (not (empty? leading-line)) (ends-with item "\n{2,}" 0))
          (set 'item (block-transforms (outdent item)))
        ; recurse for sub lists
        (begin 
           (set 'item (lists (outdent item))) 
           (set 'item (span-transforms (trim item "\n")))
           ))
    (string {<li>} item {</li>} "\n")
    )
  10)
 (dec '*list-level*)
 list-text
 )
)

(define (code-blocks txt)
 (let ((code-block {})
       (token-list '())
      )
  (replace 
    [text](?:\n\n|\A)((?:(?:[ ]{4}|\t).*\n+)+)((?=^[ ]{0,3}\S)|\Z)[/text]
    txt 
    (begin 
      (set 'code-block $1)
      ; prettyfy if it's newlisp and the modules is loaded
      (if (and (not (starts-with code-block "    !\n")) (context? Tokenize))
          ; format newlisp
          (begin 
             (set 'token-list (Tokenize (trim (detab (outdent code-block)) "\n")))
             (set 'code-block (protect (string "<pre><code>" (Pretty:pretty-output token-list) "\n</code></pre>"))))
          ; don't format 
          (begin
            ; remove flag
            (replace "[ ]{4}!\n" code-block {} 0)
            ; trim leading and trailing newlines
            (set 'code-block (trim (detab (encode-code (outdent code-block))) "\n"))
            (set '$1 {})
            (set 'code-block (string "\n\n<pre><code>" code-block "\n</code></pre>\n\n")))))
    10
    )
 )
 txt)

(define (block-quotes txt)
  (let ((block-quote {})
       )
  (replace 
    [text]((^[ \t]*>[ \t]?.+\n(.+\n)*\n*)+)[/text]
    txt 
    (begin 
      (set 'block-quote $1)
      (replace {^[ ]*>[ ]?} block-quote {} 2)
      (replace {^[ ]+$} block-quote {} 2)
      (set 'block-quote (block-transforms block-quote)) ; recurse     
      ; remove leading spaces
      (replace 
          {(\s*<pre>.+?</pre>)} 
          block-quote 
          (trim $1)
          2)
      (string "<blockquote>\n" block-quote "\n</blockquote>\n\n"))
    2
    )
  )
  txt)

(define (outdent s)
  (replace [text]^(\t|[ ]{1,4})[/text] s {} 2)
   s)

(define (detab s)
  (replace [text](.*?)\t[/text] 
    s   
    (string $1 (dup { } (- 4 (% (length $1) 4))))
    2)
 )

(define (form-paragraphs txt)
  (let ((grafs '())
        (original nil) 
       )
    (set 'txt   (trim txt "\n"))            ; strip blank lines before and after
    (set 'grafs (parse txt "\n{2,}" 0))     ; split    
    (dolist (p grafs)
      (if (set 'original (lookup p *hashed-html-blocks*))
        ; html blocks
        (nth-set (grafs $idx) original)
        ; wrap <p> tags round everything else
        (nth-set (grafs $idx) (string {<p>} (replace {^[ ]*} (span-transforms p) {} (+ 4 8 16)) {</p>}))
        ))
    (join grafs "\n\n")
  )
)

; the end



(gs:set-visible 'MAIN:Markdown-interactive true)
(gs:listen)

; eof