cormullion avatar cormullion committed fbd45db

added test files *.lsp

Comments (0)

Files changed (4)

tests/examplefiles/irc.lsp

+#!/usr/bin/env newlisp
+
+;; @module IRC
+;; @description a basic irc library
+;; @version early alpha! 0.1 2011-10-31 14:21:26
+;; @author cormullion
+;; Usage:
+;; (IRC:init "newlithper") ; a username/nick (not that one obviously :-)
+;; (IRC:connect "irc.freenode.net" 6667) ; irc/server
+;; (IRC:join-channel {#newlisp}) ; join a room
+;; either (IRC:read-irc-loop) ; loop - monitor only, no input
+;; or     (IRC:session)       ; a command-line session, end with /QUIT
+
+(context 'IRC)
+    (define Inickname)
+    (define Ichannels)
+    (define Iserver)
+    (define Iconnected)
+    (define Icallbacks '())
+    (define Idle-time 400) ; seconds
+    (define Itime-stamp)   ; time since last message was processed
+
+(define (register-callback callback-name callback-function)
+    (println {registering callback for } callback-name { : } (sym (term callback-function) (prefix callback-function)))
+    (push (list callback-name (sym (term callback-function) (prefix callback-function))) Icallbacks)) 
+
+(define (do-callback callback-name data)
+   (when (set 'func (lookup callback-name Icallbacks)) ; find first callback
+         (if-not (catch (apply func (list data)) 'error)
+                 (println {error in callback } callback-name {: } error))))
+
+(define (do-callbacks callback-name data)
+   (dolist (rf (ref-all callback-name Icallbacks))
+        (set 'callback-entry (Icallbacks (first rf)))
+        (when   (set 'func (last callback-entry))
+                (if-not (catch (apply func (list data)) 'error)
+                (println {error in callback } callback-name {: } error)))))
+
+(define (init str)
+   (set 'Inickname str)
+   (set 'Iconnected nil)
+   (set 'Ichannels '())
+   (set 'Itime-stamp (time-of-day)))
+
+(define (connect server port)
+    (set 'Iserver     (net-connect server port))
+    (net-send Iserver (format "USER %s %s %s :%s\r\n" Inickname Inickname Inickname Inickname))
+    (net-send Iserver (format "NICK %s \r\n" Inickname))
+    (set 'Iconnected true)
+    (do-callbacks "connect" (list (list "server" server) (list "port" port))))
+
+(define (identify password)
+    (net-send Iserver (format "PRIVMSG nickserv :identify %s\r\n" password)))
+
+(define (join-channel channel)
+    (when (net-send Iserver (format "JOIN %s \r\n" channel))
+          (push channel Ichannels)
+          (do-callbacks "join-channel" (list (list "channel" channel) (list "nickname" Inickname)))))
+
+(define (part chan)
+    (if-not (empty? chan)
+        ; leave specified
+        (begin
+            (net-send Iserver (format "PART %s\r\n" chan))
+            (replace channel Ichannels)
+            (do-callbacks "part" (list (list "channel" channel))))
+        ; leave all
+        (begin
+            (dolist (channel Ichannels)
+                (net-send Iserver (format "PART %s\r\n" channel))
+                (replace channel Ichannels)
+                (do-callbacks "part" (list (list "channel" channel)))))))
+
+(define (do-quit message)
+    (do-callbacks "quit" '()) ; chance to do stuff before quit...
+    (net-send Iserver (format "QUIT :%s\r\n" message))
+    (sleep 1000)
+    (set 'Ichannels '())
+    (close Iserver)
+    (set 'Iconnected nil))
+
+(define (privmsg user message)
+    (net-send Iserver (format "PRIVMSG %s :%s\r\n" user message)))
+
+(define (notice user message)
+    (net-send Iserver (format "NOTICE %s :%s\r\n" user message)))
+
+(define (send-to-server message (channel nil))
+    (cond
+        ((starts-with message {/}) ; default command character
+            (set 'the-message (replace "^/" (copy message) {} 0)) ; keep original
+            (net-send Iserver (format "%s \r\n" the-message)) ; send it
+            ; do a quit
+            (if (starts-with (lower-case the-message) "quit")
+                (do-quit { enough})))
+        (true 
+            (if (nil? channel)
+                ; say to all channels
+                (dolist (c Ichannels)
+                        (net-send Iserver (format "PRIVMSG %s :%s\r\n" c message)))
+                ; say to specified channel
+                (if (find channel Ichannels)
+                    (net-send Iserver (format "PRIVMSG %s :%s\r\n" channel message))))))
+    (do-callbacks "send-to-server" (list (list "channel" channel) (list "message" message))))
+
+(define (process-command sender command text)
+    (cond
+        ((= sender "PING")
+            (net-send Iserver (format "PONG %s\r\n" command)))
+        ((or (= command "NOTICE") (= command "PRIVMSG"))
+            (process-message sender command text))
+        ((= command "JOIN")
+            (set 'username (first (clean empty? (parse sender {!|:} 0))))
+            (set 'channel  (last  (clean empty? (parse sender {!|:} 0))))
+            (println {username } username { joined } channel)
+            (do-callbacks "join" (list (list "channel" channel) (list "username" username))))
+        (true
+            nil)))
+
+(define (process-message sender command text)
+    (let ((username {} target {} message {}))
+        (set 'username (first (clean empty? (parse sender {!|:} 0))))
+        (set 'target   (trim  (first (clean empty? (parse text {!|:} 0)))))
+        (set 'message  (slice text (+ (find {:} text) 1)))
+        (cond 
+            ((starts-with message "\001")
+                (process-ctcp username target message))
+            ((find target Ichannels)
+                (cond 
+                    ((= command {PRIVMSG})
+                        (do-callbacks "channel-message" (list (list "channel" target) (list "username" username) (list "message" message))))
+                    ((= command {NOTICE})
+                        (do-callbacks "channel-notice"  (list (list "channel" target) (list "username" username) (list "message" message))))))
+            ((= target Inickname)
+                (cond 
+                    ((= command {PRIVMSG})
+                        (do-callbacks "private-message" (list (list "username" username) (list "message" message))))
+                    ((= command {NOTICE})
+                        (do-callbacks "private-notice"  (list (list "username" username) (list "message" message))))))
+            (true                
+                nil))))
+  
+(define (process-ctcp username target message)
+    (cond
+        ((starts-with message "\001VERSION\001")
+            (net-send Iserver (format "NOTICE %s :\001VERSION %s\001\r\n" username version)))
+        ((starts-with message "\001PING")
+            (set 'data (first (rest (clean empty? (parse message { } 0)))))
+            (set 'data (trim data "\001" "\001"))
+            (net-send Iserver  (format "NOTICE %s :\001PING %s\001\r\n" username data)))
+        ((starts-with message "\001ACTION")
+            (set 'data (first (rest (clean empty? (parse message { } 0)))))
+            (set 'data (join data { }))
+            (set 'data (trim data "\001" "\001"))
+            (if (find target Ichannels)
+                (do-callbacks "channel-action" (list (list "username" username) (list "message" message))))
+            (if (= target Inickname)
+                (do-callbacks "private-action" (list (list "username" username) (list "message" message)))))
+        ((starts-with message "\001TIME\001")
+            (net-send Iserver (format "NOTICE %s:\001TIME :%s\001\r\n" username (date))))))
+
+(define (parse-buffer raw-buffer)
+    (let ((messages (clean empty? (parse raw-buffer "\r\n" 0)))
+          (sender {} command {} text {}))
+        ; check for elapsed time since last activity    
+        (when (> (sub (time-of-day) Itime-stamp) (mul Idle-time 1000))
+              (do-callbacks "idle-event")
+              (set 'Itime-stamp (time-of-day)))
+        (dolist (message messages)
+            (set 'message-parts (parse message { }))           
+            (unless (empty? message-parts)
+                (set 'sender (first message-parts))
+                (catch (set 'command (first (rest message-parts))) 'error)
+                (catch (set 'text (join (rest (rest message-parts)) { })) 'error))
+            (process-command sender command text))))
+
+(define (read-irc)
+    (let ((buffer {}))
+        (when (!= (net-peek Iserver) 0) 
+              (net-receive Iserver buffer 8192 "\n")
+              (unless (empty? buffer)
+                (parse-buffer buffer)))))
+
+(define (read-irc-loop) ; monitoring
+    (let ((buffer {}))       
+        (while Iconnected    
+            (read-irc)
+            (sleep 1000))))
+
+(define (print-raw-message data) ; example of using a callback
+    (set 'raw-data (lookup "message" data))
+    (set 'channel  (lookup "channel" data))
+    (set 'message-text raw-data)
+    (println (date (date-value) 0 {%H:%M:%S }) username {> } message-text))
+
+(define (print-outgoing-message data)
+    (set 'raw-data (lookup "message" data))
+    (set 'channel  (lookup "channel" data))
+    (set 'message-text raw-data)
+    (println (date (date-value) 0 {%H:%M:%S }) Inickname {> } message-text))
+
+(define (session); interactive terminal
+    ; must add callbacks to display messages
+    (register-callback "channel-message" 'print-raw-message)
+    (register-callback "send-to-server"  'print-outgoing-message)
+    (while Iconnected
+        (while (zero? (peek 0))
+            (read-irc))
+        (send-to-server (string (read-line 0))))
+    (println {finished session } (date))
+    (exit))
+
+; end of IRC code
+

tests/examplefiles/markdown.lsp

+#!/usr/bin/env newlisp
+
+;; @module markdown
+;; @author cormullion
+;; @description a port of John Gruber's Markdown to newLISP
+;; @location http://unbalanced-parentheses.nfshost.com/
+;; @version of date 2011-10-02 22:36:02
+;; version history: at the end
+;; a port of John Gruber's Markdown.pl (http://daringfireball.net/markdown) script to newLISP...
+;; see his original Perl script for explanations of the fearsome regexen and
+;; byzantine logic, etc...
+;; TODO:
+;;   the following Markdown tests fail:
+;;   Inline HTML (Advanced) ... FAILED
+;;   Links, reference style ... FAILED -- nested brackets 
+;;   Links, shortcut references ... FAILED
+;;   Markdown Documentation - Syntax ... FAILED
+;;   Ordered and unordered lists ... FAILED -- a nested ordered list error
+;;   parens in url : ![this is a stupid URL](http://example.com/(parens).jpg) see (Images.text)
+;;   Add: email address scrambling
+
+(context 'Hash)
+(define HashTable:HashTable)
+
+(define (build-escape-table)
+   (set '*escape-chars* [text]\`*_{}[]()>#+-.![/text])   
+   (dolist (c (explode *escape-chars*))
+        (HashTable c (hash c))))
+
+(define (init-hash txt)
+    ; finds a hash identifier that doesn't occur anywhere in the text
+    (set 'counter 0)
+    (set 'hash-prefix "HASH")
+    (set 'hash-id (string hash-prefix counter))
+    (do-while (find hash-id txt)
+           (set 'hash-id (string hash-prefix (inc counter))))
+    (Hash:build-escape-table))
+
+(define (hash s)
+   (HashTable s (string hash-id (inc counter))))
+
+(context 'markdown)
+
+(define (markdown:markdown txt)
+  (initialize)
+  (Hash:init-hash txt)
+  (unescape-special-chars 
+    (block-transforms 
+      (strip-link-definitions 
+         (protect 
+            (cleanup txt))))))
+
+(define (initialize)
+  (set '*escape-pairs*   '(
+       ({\\\\} {\})
+       ({\\`}  {`})
+       ({\\\*} {*}) 
+       ({\\_}  {_})
+       ([text]\\\{[/text] [text]{[/text])
+       ([text]\\\}[/text] [text]}[/text])
+       ({\\\[} {[})
+       ({\\\]} {]})
+       ({\\\(} {(})
+       ({\\\)} {)})
+       ({\\>}  {>})
+       ({\\\#} {#})
+       ({\\\+} {+})
+       ({\\\-} {-})
+       ({\\\.} {.})
+       ({\\!}  {!})))
+  (set '*hashed-html-blocks* '())
+  (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 (code-spans txt) 'inside-attributes)))))))))
+
+(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 'text (slice str pos (- len pos))) tokens -1))
+  tokens))
+
+(define (escape-special-chars txt (within-tag-attributes nil))
+  (let ((temp (tokenize-html txt))
+        (new-text {}))    
+    (dolist (pair temp)
+        (if (= (first pair) 'tag)
+             ; 'tag
+             (begin              
+              (set 'new-text (replace {\\} (last pair) (HashTable {\\}) 0))
+              (replace [text](?<=.)</?code>(?=.)[/text] new-text (HashTable {`}) 0)
+              (replace {\*} new-text (HashTable {*}) 0)
+              (replace {_} new-text (HashTable {_} ) 0))
+             ; 'text
+             (if  within-tag-attributes
+                  (set 'new-text (last pair))
+                  (set 'new-text (encode-backslash-escapes (last pair)))))
+        (setf (temp $idx) (list (first pair) new-text)))
+  ; return as text
+  (join (map last temp))))
+
+(define (encode-backslash-escapes t)
+   (dolist (pair *escape-pairs*)
+      (replace (first pair) t (HashTable (last pair)) 14)))
+
+(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   (HashTable {\\}) 0)
+  (replace {_}  s   (HashTable {_}) 0)
+  (replace "{"  s   (HashTable "{") 0)
+  (replace {\[} s   (HashTable {[}) 0)
+  (replace {\]} s   (HashTable {]}) 0)
+  (replace {\\} s   (HashTable "\\") 0))
+
+(define (code-spans s)
+  (replace  
+    {(?<!\\)(`+)(.+?)(?<!`)\1(?!`)} 
+    s 
+    (string {<code>} (encode-code (trim $2)) {</code>}) 
+    2))
+
+(define (encode-alt s)
+  (replace {&} s "&amp;" 0)
+  (replace {"} s "&quot;" 0))
+
+(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 (HashTable {*}) 0)
+              (replace {_}  url (HashTable {_}) 0) 
+            ))             
+       (if (last (lookup id-ref *link-database*))
+            ; title
+           (begin
+             (set 'title (last (lookup id-ref *link-database*)))
+             (replace {"}  title {&quot;} 0)
+             (replace {\*} title (HashTable {*}) 0)
+             (replace {_}  title (HashTable {_}) 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 (HashTable {*}) 0)
+               (replace {_}  title (HashTable {_}) 0))
+             (set 'title {}))           
+        (replace {\*} url (HashTable {*}) 0)
+        (replace {_} url (HashTable {_}) 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)))
+
+(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 (HashTable {*}) 0)
+             (replace {_}  url (HashTable {_}) 0)
+             (if (set 'title (last (lookup id  *link-database*)))
+                 (begin 
+                      (replace {"}  title {&quot;} 0)
+                      (replace {\*} title (HashTable {*}) 0)
+                      (replace {_}  title (HashTable {_}) 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...
+  
+  ; what about this regex instead?
+  (set 'ref-link-regex {(\[(.*?)\][ ]?\[(.*?)\])})
+   
+  (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  (HashTable {*}) 0)
+             (replace {_}  title  (HashTable {_}) 0))
+           (set 'title {}))           
+      (replace {\*} url (HashTable {*}) 0)
+      (replace {_}  url (HashTable {_}) 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 ...
+)
+
+(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))
+
+(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  
+  ))
+
+(define (line-breaks txt)
+  ; handles line break markers
+  (replace " {2,}\n" txt " <br/>\n" 0))
+
+(define (hex-str-to-unicode-char strng)
+   ; given a five character string, assume it's "U" + 4 hex chars and convert
+   ; return the character...
+   (char (int (string "0x" (1 strng)) 0 16)))
+
+(define (ustring s)
+  ; any four digit string preceded by U 
+  (replace "U[0-9a-f]{4,}" s (hex-str-to-unicode-char $0) 0))
+
+(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
+  
+  ; convert inline Unicode:
+  (set 'txt (ustring txt))
+  (replace "\n[ \t]+\n" txt "\n\n" 0) ; lines with only spaces and tabs
+  )
+
+(define (protect txt)
+ ; protect or "hash html blocks" 
+ (letn ((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])
+       (results '())
+       (chunk-count (length (set 'chunks (parse txt "\n\n"))))
+       (chunk-size 500))
+   
+   ; due to a limitation in PCRE, long sections have to be divided up otherwise we'll crash
+   ; so divide up long texts into chunks, then do the regex on each chunk
+   ; not an ideal solution, but it works ok :( 
+  
+   (for (i 0 chunk-count chunk-size)
+       ; do a chunk
+       (set 'text-chunk (join (i (- (min chunk-count (- (+ i chunk-size) 1)) i) chunks) "\n\n"))
+       (dolist (rgx (list nested-block-regex liberal-tag-regex hr-regex html-comment-regex))
+         (replace 
+            rgx 
+            text-chunk
+            (begin
+              (set 'key (Hash:hash $1))
+              (push (list key $1 ) *hashed-html-blocks* -1)
+              (string "\n\n" key "\n\n"))
+            2))
+        ; save this partial result
+        (push text-chunk results -1)
+    ) ; for
+  ; return string result
+  (join results "\n\n")))
+
+(define (unescape-special-chars t)
+ ; Swap back in all the special characters we've hidden. 
+  (dolist (pair (HashTable))
+    (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))
+
+(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)))
+
+(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
+      )))
+
+(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)
+      ; format if Nestor module is loaded and it's not marked as plain
+      (if (and (not (starts-with code-block "    ;plain\n")) (context? Nestor))
+          ; format newlisp
+          (begin 
+             ; remove flag if present
+            (replace "[ ]{4};newlisp\n" code-block {} 0)       
+            (set 'code-block (protect (Nestor:nlx-to-html (Nestor:my-read (trim (detab (outdent code-block)) "\n")))))
+            code-block)
+          ; don't format 
+          (begin
+            ; trim leading and trailing newlines
+            (replace "[ ]{4};plain\n" code-block {} 0)
+            (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)))
+
+(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)))
+
+(define (outdent s)
+  (replace [text]^(\t|[ ]{1,4})[/text] s {} 2))
+
+(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
+        (setf (grafs $idx) original)
+        ; wrap <p> tags round everything else
+        (setf (grafs $idx) (string {<p>} (replace {^[ ]*} (span-transforms p) {} (+ 4 8 16)) {</p>}))))
+    (join grafs "\n\n")))
+
+[text]
+; three command line arguments: let's hope last one is a file
+(when (= 3 (length (main-args)))
+      (println (markdown (read-file (main-args 2))))
+      (exit))
+
+; hack for command-line and module loading
+(set 'level (sys-info 3))
+
+; if level is 2, then we're probably invoking markdown.lsp directly
+; if level is > 3, then we're probably loading it into another script...
+    
+(when (= level 2)
+   ; running on command line, read STDIN and execute:
+   (while (read-line)
+          (push (current-line) *stdin* -1))
+   (println (markdown (join *stdin* "\n")))
+   (exit))
+[/text]
+
+;; version 2011-09-16 16:31:29
+;;   Changed to different hash routine. Profiling shows that hashing takes 40% of the execution time.
+;;   Unfortunately this new version is only very slightly faster.
+;;   Command-line arguments hack in previous version doesn't work.
+;;
+;; version 2011-08-18 15:04:40
+;;   various fixes, and added hack for running this from the command-line:
+;;     echo "hi there"     | newlisp markdown.lsp 
+;;     echo "hello world"  | markdown.lsp 
+;;     cat file.text       | newlisp markdown.lsp
+;;
+;; version 2010-11-14 17:34:52
+;;    some problems in ustring. Probably remove it one day, as it's non standard...
+;;
+;; version 2010-10-14 18:41:38
+;;    added code to work round PCRE crash in (protect ...
+;;
+;; version date 2010-07-10 22:20:25
+;;    modified call to 'read' since lutz has changed it
+;;
+;; version date 2009-11-16 22:10:10
+;;    fixed bug in tokenize.html
+;;
+;; version date 2008-10-08 18:44:46
+;;    changed nth-set to setf to be version-10 ready. 
+;;    This means that now this script will NOT work with
+;;    earlier versions of newLISP!!!!!!!!!!!
+;;    requires Nestor if you want source code colouring...
+;;
+;; version date 2008-08-08 16:54:56
+;;    changed (unless to (if (not ... :(
+;;
+;; version date 2008-07-20 14:!2:29
+;;    added hex-str-to-unicode-char ustring
+;;
+;; version date 2008-03-07 15:36:09
+;;    fixed load error
+;;
+;; version date 2007-11-17 16:20:57
+;;    added syntax colouring module
+;; 
+;; version date  2007-11-14 09:19:42
+;;    removed reliance on dostring for compatibility with 9.1
+
+
+; eof

tests/examplefiles/newlisp-parser.lsp

+#!/usr/bin/env newlisp
+
+;; @module Nlex
+;; @author cormullion
+;; @description  newLISP source code lexer/tokenizer/parser
+;; @location somewhere on github
+;; @version 0.1 of 2011-09-19 08:55:19
+;;<h4>About this module</h4>
+;;<p>The Nlex module is a lexer/tokenizer/parser for newLISP source code.
+;; An expert from StackOverflow xplains:
+;; A tokenizer breaks a stream of text into tokens.
+;; A lexer is basically a tokenizer, but it usually attaches extra context to the tokens.
+;; A parser takes the stream of tokens from the lexer and turns it into an abstract syntax tree representing the program represented by the original text.</p>
+;;<p><b>Usage</b></p>
+;;<p>To tokenize/parse source code stored in symbol 'original, use <b>parse-newlisp</b>, To convert the parsed source tree back to plain source, use <b>nlx-to-plaintext</b>:</p>
+;;<pre>
+;;(letn ((converted    (Nlex:parse-newlisp     original-source)) ; parses 
+;;       (new-original (Nlex:nlx-to-plaintext  converted)))      ; converts back to plain text
+;;</pre>
+;;<p>After this round trip, original-source and new-original should be identical.</p>
+;;<p></p>
+
+(context 'Nlex)
+
+; class variables
+
+(define *cursor*)
+(define *source-length*)
+(define *source-list*)
+(define *depth*)
+(define *tree*)
+(define *loc*)
+
+(define (get-next-char)
+ (let ((nch ""))
+   (if (< *cursor* *source-length*)
+       (begin
+          (set 'nch (*source-list* *cursor*))
+          (inc *cursor* (utf8len nch)))
+       (set 'nch nil))
+   nch))
+
+(define (peek-char)
+ (let ((pch ""))
+   (if (< *cursor* *source-length*)
+       (set 'pch (*source-list* *cursor*))
+       (set 'pch nil))))
+
+(define (char-identifier-first? c)
+  (not (find (lower-case c) [text] #;"'(){}.0123456789[/text])))
+  
+(define (char-identifier? c)
+  (not (find (lower-case c) { "':,()})))
+
+(define (char-numeric-first? c)
+   (find c {123456789+-.0}))
+
+(define (char-numeric? c)
+   (find c {0123456789+-.xXabcdefABracketedCommandDEF}))
+
+(define (char-whitespace? c)
+  (or (= c " ") (= c "\n") (= c "\t")))
+
+(define (open-paren-token)
+  (add-to-parse-tree '(LeftParen "(")))
+
+(define (close-paren-token)
+  (add-to-parse-tree '(RightParen ")")))
+
+(define (read-comment c)
+  (let ((res c) (ch ""))
+     (while (and (!= (set 'ch (get-next-char)) "\n") ch)
+        (push ch res -1))
+    (add-to-parse-tree (list 'Comment (string res "\n")))))
+    
+(define (read-identifier c)
+  (let ((res c) (ch ""))
+   ; look for end of identifier
+    (while (and (not (find (set 'ch (peek-char)) " \"',()\n\t\r")) (!= ch nil))
+      (push (get-next-char) res -1))
+    (add-to-parse-tree (list 'Symbol res))))
+
+(define (read-number-scanner list-so-far)
+    (let ((next-char (peek-char)))
+      ;; if next-char is a digit then recurse
+      (if (and (char-numeric? next-char) next-char)
+          (read-number-scanner (cons (get-next-char) list-so-far))
+          (reverse list-so-far))))
+
+(define (precise-float str)
+; more faithful to original format than newLISP's float?
+  (let ((p "") (q ""))
+    (map set '(p q) (parse str "."))
+    (append p "." q)))
+    
+(define (scientific-float str)
+  (let ((p "") (q ""))
+    (map set '(p q) (parse str "e"))
+    (append p "e" q)))
+
+(define (read-number c)
+  (let ((res '() number-as-string ""))
+     (set 'number-as-string (join (read-number-scanner (list c))))
+     (cond
+       ; try hex first
+       ((starts-with (lower-case number-as-string) "0x")
+          (set 'res  (list 'Hex number-as-string)))
+       ; scientific notation if there's an e
+       ((find "e" (lower-case number-as-string))
+          (set 'res  (list 'Scientific (scientific-float number-as-string))))
+       ; float?
+       ((find "." number-as-string)
+          ; newLISP's float function isn't quite what we want here     
+          (set 'res  (list 'Float (precise-float number-as-string))))
+       ; octal, not hex or float? 017 is OK, 019 is read as 10
+       ((and (starts-with (lower-case number-as-string) "0") 
+             (> (length number-as-string) 1)
+             (empty? (difference (explode number-as-string) (explode "01234567"))))
+          (set 'res (list 'Octal number-as-string)))
+       ; perhaps an integer?  019 is read as 19 ...
+       ((integer? (int number-as-string 0 10))
+         (set 'res  (list 'Integer (int number-as-string 0 10))))
+       ; give up
+       (true
+         (set 'res (list 'NaN "NaN"))))
+  (add-to-parse-tree res)))
+
+(define (read-quote)
+   (add-to-parse-tree '(Quote "'")))
+
+(define (read-quoted-string)
+  (let ((res {}) (ch {}))
+     (while (and (!= (set 'ch (get-next-char)) {"}) ch)
+        (push ch res -1)
+        ; check for backslashed quotes
+        (when (= ch {\}) 
+              (set 'ch (get-next-char))
+              (push ch res -1)))
+    (add-to-parse-tree (list 'QuotedString res))))
+
+(define (read-braced-string)
+  (let ((res "") (ch {}) (level 1)) 
+  ; we've already seen the first { so we're up to level 1
+     (while (> level 0)
+         (set 'ch (get-next-char))
+         (if (= ch "{") (inc level))
+         (if (= ch "}") (dec level))
+         (if (or (< level 0) (= ch nil)) (throw-error (string "error in a braced string at character " *cursor*)))
+         ; don't push final "}"
+         (if (and (> level 0)) (push ch res -1)))
+    (add-to-parse-tree (list 'BracedString res))))
+
+(define (read-bracketed-string ch)
+  (let ((res "") (ch {}))  
+    (cond
+     ; bracketed TEXT?
+     ((= (lower-case (join (slice *source-list* (- *cursor* 1) 6))) "[text]")
+         ; look for final [/text]
+         (inc *cursor* 5)
+         ; look for end
+         (while (and  (< *cursor* (- *source-length* 7)) 
+                      (!= (lower-case (join (*cursor* 7 *source-list*))) "[/text]")
+                      ch)
+                (push (get-next-char) res -1))
+         (inc *cursor* 7)
+         (add-to-parse-tree (list 'BracketedText res)))
+     ; bracketed CMD?
+     ((= (lower-case (join (slice *source-list* (- *cursor* 1) 5))) "[cmd]")
+         ; look for final [/cmd]
+         (inc *cursor* 4)
+         (while (and  (< *cursor* (- *source-length* 6)) 
+                      (!= (lower-case (join (*cursor* 6 *source-list*))) "[/cmd]")
+                      ch)
+                (push (get-next-char) res -1))
+         (inc *cursor* 6)
+         (add-to-parse-tree (list 'BracketedCommand res)))
+     ; must be those weird bracketed identifiers    
+     (true
+         (while (and (!= (set 'ch (get-next-char)) {]}) ch)
+            (push ch res -1)
+            ; check for backslashed quotes
+            (when (= ch {\}) 
+                  (set 'ch (get-next-char))
+                  (push ch res -1)))
+            (add-to-parse-tree (list 'BracketedIdentifier res))))))
+
+(define (read-whitespace ch)
+  (let ((res ch))
+     (while (find (set 'ch (peek-char)) " \n\t")
+        (push (get-next-char) res -1))
+    (add-to-parse-tree (list 'WhiteSpace (base64-enc res)))))
+
+(define (get-token)
+ (let ((first-char (get-next-char)))
+    (if first-char
+      (cond 
+            ; a - or + could be the start of a symbol or a number, so look at the next char
+            ((or (= first-char "-") (= first-char "+"))
+                (if (find (peek-char) "1234567890")
+                    (read-number first-char)
+                    (read-identifier first-char)))
+            ((char-whitespace? first-char)   
+               (read-whitespace first-char))
+            ((= first-char {(})
+               (open-paren-token))
+            ((= first-char {)})
+               (close-paren-token))
+            ((= first-char {#})
+               (read-comment first-char))
+            ((= first-char {;})
+               (read-comment first-char))
+            ((= first-char {"})
+               (read-quoted-string))
+            ((= first-char "{")
+               (read-braced-string))
+            ((= first-char "[")
+               (read-bracketed-string first-char))
+            ((= first-char {'})
+               (read-quote))
+            ((char-numeric-first? first-char)
+               (read-number first-char))
+            ((char-identifier-first? first-char)
+               (read-identifier first-char))
+            (true (throw-error (string "{" first-char "} is an unrecognized token")))))))
+
+(define (add-to-parse-tree token-pair)
+  (let (token (first token-pair))
+  (cond 
+    ((= token 'LeftParen)
+        (inc *depth*)
+        (push '((LeftParen "(")) *tree* *loc*)
+        (push -1 *loc*))
+    ((= token 'RightParen)
+        (push '(RightParen ")") *tree* *loc*)
+        (dec *depth*)
+        (pop *loc*))
+    (true
+        (push token-pair *tree* *loc*)
+        true))))
+
+(define (parse-newlisp src)
+  ; main function: tokenize/lex/parse the string in src
+  (set '*depth* 0 
+       '*tree* '() 
+       '*loc* '(-1) 
+       '*cursor* 0 
+       '*source-list*   (explode src) 
+       '*source-length* (utf8len src)
+       '*source-length* (length *source-list*))
+  (while (< *cursor* *source-length*)
+         (get-token))
+  *tree*)
+
+(define (nlx-to-plaintext nlx (depth 0))
+   (if (= depth 0) (set 'buff {})) ; if first pass, initialize a buffer
+   (dolist (element nlx)
+    (set 'token-type (first element) 'token-value (last element))
+    (if (atom? token-type)
+        (cond 
+           ((= token-type 'LeftParen) ; left parenthesis
+                (extend buff {(}))
+           ((= token-type 'RightParen) ; right parenthesis
+                (extend buff {)}))
+           ((= token-type 'WhiteSpace) ; whitespace
+                (dostring (s (base64-dec token-value)) 
+                  (extend buff (string (char s)))))
+           ((= token-type 'BracedString) ; braced string
+                (extend buff (string  "{" token-value "}")))
+           ((= token-type 'QuotedString) ; quoted string
+                (extend buff (string  {"} token-value {"})))
+           ((= token-type 'BracketedText) ; bracketed  text
+                (extend buff (string  {[text]} token-value {[/text]})))        
+           ((= token-type 'Quote); quote
+                (extend buff (string  "'")))
+           ((= token-type 'Comment) ; comment
+                (extend buff (string (last element) "\n")))
+           ((= token-type 'Integer) ; int
+                (extend buff (string (int (last element)))))
+           ((= token-type 'Float) ; float
+                (extend buff (string (precise-float (last element)))))  
+           ((= token-type 'Scientific) ; scientific notation
+                (extend buff (scientific-float (last element))))  
+           ((= token-type 'BracketedCommand) ; bracketed command
+               (extend buff (string {[cmd]} (last element) {[/cmd]})))
+           ((or 
+                (= token-type 'Symbol) ; close parenthesis
+                (= token-type 'Hex) ; hex
+                (= token-type 'NaN) ; not a number
+                (= token-type 'Octal) ; octal
+                )
+                (extend buff (string (last element))))
+           ((= token-type 'BracketedIdentifier) ; bracketed identifier
+                (extend buff (string {[} (last element) {]}))))
+        ; not an atom, so recurse but don't initialize buffer
+        (nlx-to-plaintext element 1)))
+   buff)
+
+;eof

tests/examplefiles/reversi.lsp

+#!/usr/bin/env newlisp
+;; @module reversi.lsp
+;; @description a simple version of Reversi: you as white against newLISP as black
+;; @version 0.1 alpha August 2007
+;; @author cormullion
+;;
+;; 2008-10-08 21:46:54
+;; updated for newLISP version 10. (changed nth-set to setf)
+;; this now does not work with newLISP version 9!
+;;
+;; This is my first attempt at writing a simple application using newLISP-GS.
+;; The game algorithms are basically by 
+;; Peter Norvig http://norvig.com/paip/othello.lisp
+;; and all I've done is translate to newLISP and add the interface...
+;;
+;; To-Do: work out how to handle the end of the game properly...
+;; To-Do: complete newlispdoc for the functions
+
+(constant 'empty 0) 
+(constant 'black 1) 
+(constant 'white 2)
+(constant 'outer 3) ; squares outside the 8x8 board
+
+(set '*board* '()) ; the master board is a 100 element list
+(set '*moves* '()) ; list of moves made
+
+; these are the 8 different directions from a square on the board
+
+(set 'all-directions '(-11 -10 -9 -1 1 9 10 11))
+
+; return a list of all the playable squares (the 8 by 8 grid inside the 10by10
+
+(define (all-squares)
+  (local (result)
+     (for (square 11 88)
+        (if (<= 1 (mod square 10) 8)
+           (push square result -1)))
+result))
+
+; make a board
+
+(define (make-board)
+  (set '*board* (dup outer 100))
+  (dolist (s (all-squares))
+     (setf (*board* s) empty)))
+
+; for testing and working at a terminal
+
+(define (print-board)
+  (print { })
+  (for (c 1 8)
+     (print c))
+  (set 'c 0)
+  (for (i 0 99)
+     (cond
+        ((= (*board* i) 0) (print {.}))
+        ((= (*board* i) 1) (print {b}))
+        ((= (*board* i) 2) (print {w})))
+     (if (and (<= i 88) (= (mod (+ i 1) 10) 0)) ; newline
+        (print "\n" (inc c))))
+  (println "\n"))
+
+; the initial starting pattern
+
+(define (initial-board)
+  (make-board)
+  (setf (*board* 44) white)
+  (setf (*board* 55) white)
+  (setf (*board* 45) black)
+  (setf (*board* 54) black))
+
+(define (opponent player)
+  (if (= player black) white black))
+
+(define (player-name player)
+  (if (= player white) "white" "black"))
+  
+(define (valid-move? move)
+  (and 
+     (integer? move)
+     (<= 11 move 88)
+     (<= 1 (mod move 10) 8)))
+
+(define (empty-square? square)
+  (and
+     (valid-move? square)
+     (= (*board* square) empty)))
+     
+; test whether a move is legal. The square must be empty
+; and it must flip at least one of the opponent's piece
+
+(define (legal-move? move player)
+  (and 
+     (empty-square? move)
+     (exists (fn (dir) (would-flip? move player dir)) all-directions)))
+
+; would this move by player result in any flips in the given direction?
+; if so, return the number of the 'opposite' (bracketing) piece's square
+
+(define (would-flip? move player dir) 
+  (let 
+     ((c (+ move dir)))
+     (and 
+        (= (*board* c) (opponent player))
+        (find-bracketing-piece (+ c dir) player dir))))
+  
+(define (find-bracketing-piece square player dir)
+  ; return the square of the bracketing piece, if any
+  (cond
+     ((= (*board* square) player) square)
+     ((= (*board* square) (opponent player))
+        (find-bracketing-piece (+ square dir) player dir))
+     (true nil)))
+
+(define (make-flips move player dir)
+  (let 
+     ((bracketer (would-flip? move player dir))
+      (c (+ move dir)))
+  (if bracketer
+     (do-until (= c bracketer)
+        (setf (*board* c) player)
+        (push c *flips* -1)
+        (inc c dir)))))
+
+; make the move on the master game board, not yet visually
+
+(define (make-move move player)
+  (setf (*board* move) player)
+  (push move *moves* -1)
+  (set '*flips* '()) ; we're going to keep a record of the flips made
+  (dolist (dir all-directions)
+     (make-flips move player dir)))
+
+(define (next-to-play previous-player)
+  (let ((opp (opponent previous-player)))
+     (cond
+        ((any-legal-move? opp) opp)
+        ((any-legal-move? previous-player)
+           (println (player-name opp) " has no moves")
+           previous-player)
+        (true nil))))
+        
+; are there any legal moves (returns first) for this player?
+(define (any-legal-move? player)
+  (exists (fn (move) (legal-move? move player)) 
+     (all-squares)))
+
+; a list of all legal moves might be useful
+(define (legal-moves player)
+  (let ((result '()))
+     (dolist (move (all-squares))
+        (if (legal-move? move player)
+           (push move result)))
+  (unique result)))
+
+; define any number of strategies that can be called on to calculate
+; the next computer move. This is the only one I've done... - make 
+; any legal move at random!
+
+(define (random-strategy player)
+  (seed (date-value))
+  (apply amb (legal-moves player)))
+
+; get the next move using a particular strategy
+
+(define (get-move strategy player)
+ (let ((move (apply strategy (list player))))
+  (cond
+     ((and
+        (valid-move? move)
+        (legal-move? move player))
+            (make-move move player))
+     (true  
+        (println "no valid or legal move for " (player-name player) )
+        nil))
+  move))
+
+; that's about all the game algorithms for now
+; now for the interface
+
+(if (= ostype "Win32")
+   (load (string (env "PROGRAMFILES") "/newlisp/guiserver.lsp"))
+   (load "/usr/share/newlisp/guiserver.lsp")
+)
+
+(gs:init)
+(map set '(screen-width screen-height) (gs:get-screen))
+(set 'board-width 540)
+; center on screen
+(gs:frame 'Reversi (- (/ screen-width 2) (/ board-width 2)) 60 board-width 660 "Reversi")
+(gs:set-border-layout 'Reversi)
+
+(gs:canvas 'MyCanvas 'Reversi)
+  (gs:set-background 'MyCanvas '(.8 .9 .7 .8))
+  (gs:mouse-released 'MyCanvas 'mouse-released-action true)
+
+(gs:panel 'Controls)
+  (gs:button 'Start 'start-game "Start")
+
+(gs:panel 'Lower)
+  (gs:label 'WhiteScore "")
+  (gs:label 'BlackScore "")
+
+(gs:add-to 'Controls 'Start )
+(gs:add-to 'Lower 'WhiteScore 'BlackScore)
+(gs:add-to 'Reversi 'MyCanvas "center" 'Controls "north" 'Lower "south")
+
+(gs:set-anti-aliasing true)
+(gs:set-visible 'Reversi true)
+
+; size of board square, and radius/width of counter
+(set 'size 60 'width 30)
+
+; initialize the master board
+
+(define (initial-board)
+  (make-board)
+  (setf (*board* 44) white)
+  (setf (*board* 55) white)
+  (setf (*board* 45) black)
+  (setf (*board* 54) black)  
+)
+
+; draw a graphical repesentation of the board
+
+(define (draw-board)
+  (local (x y)
+     (dolist (i (all-squares))
+        (map set '(x y) (square-to-xy i))
+        (gs:draw-rect 
+           (string x y) 
+           (- (* y size) width ) ; !!!!!!
+           (- (* x size) width )
+           (* width 2)
+           (* width 2)
+           gs:white))))
+
+(define (draw-first-four-pieces)
+  (draw-piece 44 "white")
+  (draw-piece 55 "white")
+  (draw-piece 45 "black")
+  (draw-piece 54 "black"))
+
+; this next function can mark the legal moves available to a player
+
+(define (show-legal-moves player)
+  (local (legal-move-list x y)
+     (set 'legal-move-list (legal-moves player))
+     (dolist (m (all-squares))
+        (map set '(x y) (square-to-xy m))
+        (gs:draw-rect 
+           (string x y) 
+           (- (* y size) width ) ; !!!!!!
+           (- (* x size) width )
+           (* width 2)
+           (* width 2)
+           (if (find m legal-move-list) gs:blue gs:white)
+        )
+     )
+  )
+)
+
+; convert the number of a square on the master board to coordinates
+
+(define (square-to-xy square) 
+  (list (/ square 10) (mod square 10)))
+
+; draw one of the pieces
+
+(define (draw-piece square colour)
+  (local (x y)
+  (map set '(x y) (square-to-xy square))
+  (cond 
+     ((= colour "white") 
+        (gs:fill-circle 
+           (string x y) 
+           (* y size)  ; !!!!!!! y first, cos y is x ;-)
+           (* x size) 
+           width
+           gs:white))
+     
+     ((= colour "black") 
+        (gs:fill-circle 
+           (string x y) 
+           (* y size) 
+           (* x size) 
+           width
+           gs:black))
+     
+     ((= colour "empty") 
+        (gs:draw-rect 
+           (string x y) 
+           (- (* y size) width ) 
+           (- (* x size) width )
+           (* width 2)
+           (* width 2)
+           gs:white))
+  )))
+
+; animate the pieces flipping
+
+(define (flip-piece square player)
+; flip by drawing thinner and fatter ellipses 
+; go from full disk in opposite colour to invisible
+; then from invisible to full disk in true colour
+  (local (x y colour)
+     (map set '(x y) (square-to-xy square))
+     ; delete original piece
+     (gs:delete-tag (string x y))
+     (set 'colour (if (= player 2) gs:black gs:white )) 
+     (for (i width  1 -3)
+        (gs:fill-ellipse 
+           (string x y {flip} i) 
+           (* y size) ; y first :-) !!! 
+           (* x size) 
+           i 
+           width
+           colour)
+        (sleep 20)  ; this might need adjusting...
+        (gs:delete-tag (string x y {flip} i))
+     )
+     (set 'colour (if (= player 2) gs:white gs:black))
+     (for (i 1 width 3)
+        (gs:fill-ellipse 
+           (string x y {flip} i) 
+           (* y size) ; :-) !!! 
+           (* x size) 
+           i 
+           width
+           colour)
+        (sleep 20)  
+        (gs:delete-tag (string x y {flip} i))
+     )
+     ; draw the piece again
+     (gs:fill-circle 
+           (string x y) 
+           (* y size)
+           (* x size) 
+           width
+           colour)
+  )
+)
+
+(define (do-move move player)
+  (cond 
+     ; check if the move is good ...
+     ((and (!= player nil)
+           (valid-move? move)
+           (legal-move? move player))
+           
+           ; ... play it
+              ; make move on board
+              (make-move move player)
+              ; and on screen
+              (draw-piece move (player-name player))
+              (gs:update)
+              ; do flipping stuff
+              
+              ; wait for a while
+              (sleep 1000)
+  
+              ; then do flipping
+              (dolist (f *flips*)
+                 (flip-piece f player))
+              
+              (inc *move-number*)
+              (draw-piece move (player-name player))
+              (gs:update)
+
+              ; update scores
+              (gs:set-text 'WhiteScore 
+                 (string "White: " (first (count (list white) *board*))))
+              (gs:set-text 'BlackScore
+                 (string "Black: " (first (count (list black) *board*))))
+              )
+     ; or return nil
+     (true 
+           nil)))
+
+; the game is driven by the mouse clicks of the user
+; in reply, the computer plays a black piece
+; premature clicking is possible and possibly a bad thing...
+
+(define (mouse-released-action x y button modifiers tags)
+  ; extract the tag of the clicked square
+  (set 'move (int (string (first tags)) 0 10))
+  (if (do-move move player)
+     (begin
+        (set 'player (next-to-play player))
+        ; there is a training mode - legal squares are highlighted
+        ; you can uncomment the next line...
+        ; (show-legal-moves player)
+        (gs:update)
+        
+        ; wait for black's reply
+        (gs:set-cursor 'Reversi "wait")
+        (gs:set-text 'Start "black's move - thinking...")
+        ; give the illusion of Deep Thought...
+        (sleep 2000)
+        ; black's reply
+        ; currently only the random strategy has been defined...
+        (set 'strategy random-strategy)
+        (set 'move (apply strategy (list player)))
+        (do-move move player)
+        (set 'player (next-to-play player))
+        ; (show-legal-moves player) ; to see black's moves
+        (gs:set-text 'Start "your move")
+        (gs:set-cursor 'Reversi "default")
+        (gs:update))))
+
+(define (start-game)
+  (gs:set-text 'Start "Click a square to place a piece!")
+  (gs:disable 'Start)
+  (set 'player white))
+
+(define (start)
+  (gs:set-text 'Start "Start")
+  (gs:enable 'Start)
+  (set  '*move-number* 1
+        '*flips* '())
+  (initial-board)
+  (draw-board)
+  (draw-first-four-pieces))
+
+(start)
+
+(gs:listen)
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.