diff options
| -rwxr-xr-x | tests/examplefiles/irc.lsp | 214 | ||||
| -rwxr-xr-x | tests/examplefiles/markdown.lsp | 679 | ||||
| -rw-r--r-- | tests/examplefiles/newlisp-parser.lsp | 298 | ||||
| -rw-r--r-- | tests/examplefiles/reversi.lsp | 427 |
4 files changed, 1618 insertions, 0 deletions
diff --git a/tests/examplefiles/irc.lsp b/tests/examplefiles/irc.lsp new file mode 100755 index 00000000..6f45976a --- /dev/null +++ b/tests/examplefiles/irc.lsp @@ -0,0 +1,214 @@ +#!/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 + diff --git a/tests/examplefiles/markdown.lsp b/tests/examplefiles/markdown.lsp new file mode 100755 index 00000000..8159082b --- /dev/null +++ b/tests/examplefiles/markdown.lsp @@ -0,0 +1,679 @@ +#!/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 : .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 "&" 0) + (replace {<} s "<" 0) + (replace {>} s ">" 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 "&" 0) + (replace {"} s """ 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 {"} 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 {"} 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:  + (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 {"} 0) + (set 'alt-text {})) + (if title + (begin + (replace {"} title {"} 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 {"} 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 {"} 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 {"} 0)) + (if title + (begin + (replace {"} title {"} 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 + {&} + 10 + ) + (replace + [text]<(?![a-z/?\$!])[/text] + txt + {<} + 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 {"} 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
\ No newline at end of file diff --git a/tests/examplefiles/newlisp-parser.lsp b/tests/examplefiles/newlisp-parser.lsp new file mode 100644 index 00000000..985615b3 --- /dev/null +++ b/tests/examplefiles/newlisp-parser.lsp @@ -0,0 +1,298 @@ +#!/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 diff --git a/tests/examplefiles/reversi.lsp b/tests/examplefiles/reversi.lsp new file mode 100644 index 00000000..fa9a333c --- /dev/null +++ b/tests/examplefiles/reversi.lsp @@ -0,0 +1,427 @@ +#!/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)
\ No newline at end of file |