目前是用一个修改版的TinyScheme做解释器，增加了平台实现相关的clrscr、inkey（=getch）、exit三个用于终端界面的函数。
为了以后移植方便，语言特性限定在IEEE和R5RS的最小子集的交集。
即无eval且call/cc只能局部跳出用，并只用到最基本的两种数字类型。
本来在别处写了一点说明和注释，价值不大就不搬过来了。
代码这里合并为单文件。
(define (require name)
;(push! *loaded*)
(load (string-append (symbol->string name) ".ss")))
;;;=====(load "core.ss")=====
(define (filter pred list)
(cond
((null? list) '())
((pred (car list))
(cons (car list) (filter pred (cdr list))))
(else (filter pred (cdr list)))))
(define (curry fun . args)
(lambda x
(apply fun (append args x))))
(define (assert ture . msgs)
(if (not ture) (begin (for-each (lambda (x) (display x)) msgs) (error))))
;;;=====(require 'util)=====
(define (wait-key)
(define (co key-map)
(define (co lst)
(cons
(char-downcase
(string-ref (symbol->string (car lst)) 0))
(cadr lst)))
(map co key-map))
(define key-map
(co '((w u)(s d)(a l)(d r)(z a)(x b)(c s))))
(let loop ()
(cond
((assoc (inkey) key-map)
=>(lambda (x) (if x (cdr x) (loop)))))))
;;;key-test
;(clrscr)
;(let loop ()
; (let ((c (inkey)))
; (display (char->integer c))
; (newline)
; (loop)))
;;;=====(require 'view)=====
(define (dispatch->callable host)
(define (object message . args)
(apply (host message) args))
object)
;;;choose:a modal scene
(define (ui-choose msg . items)
(define (show vec cur)
(define cur (modulo cur (vector-length vec)))
(clrscr)
(display msg)
(newline)
(do ((i 0 (+ i 1))) ((= i (vector-length vec)) 1)
(display (if (= i cur) " * " " "))
(display (vector-ref vec i))
(newline))
(let ((k (wait-key)))
(case k
((u) (show vec (- cur 1)))
((d) (show vec (+ cur 1)))
((a) (+ cur 1))
(else (show vec cur)))))
(show (list->vector items) 0))
;(display (ui-choose "where to go?" "walk" "eat" "sleep"))
;;;(int*int->())->(symbol->procedure)
(define (make-movable call-with-this-new-position)
(define position (list 0 0))
(define (position-ref)
position)
(define (position-copy)
(append position))
(define (position-set! x y)
(set-car! position x)
(set-car! (cdr position) y))
(define (move dx dy)
(let ((new-x (+ dx (car position)))
(new-y (+ dy (cadr position))))
;;tail-rec/cps
(call-with-this-new-position this new-x new-y)))
(define (dispatch message)
(case message
((position-ref) position-ref)
((position) position-copy)
((position-set!) position-set!)
((put) position-set!)
((move) move)
(else (error message))))
(define this (dispatch->callable dispatch))
this)
;;;ui-display-map
(define (map-view-display width height call-with-char-position)
(do ((y 0 (+ y 1))) ((= y height))
(do ((x 0 (+ x 1))) ((= x width))
(let ((chr (call-with-char-position x y)))
(if (or (not chr) (null? chr))
(display ".")
(display chr))))
(display "\n")))
;;;with-system-mune
(define (input-and-move move)
(case (wait-key)
((u) (move +0 -1))
((d) (move +0 +1))
((l) (move -1 +0))
((r) (move +1 +0))))
;;assoc-all
(define (assoc-all obj alist)
(let ((f (filter (lambda (x) (equal? (car x) obj)) alist)))
(if (null? f) #f f)))
;;make-pos-list
(define (pos-list-of-strs map-data)
'(demo-data
("##....###"
"#.$.....#"
"#.....@.#"
"#.$..####"))
(let loop ((x 0) (y 0) (w 0) (h 0)(it map-data) (ret '()))
(cond
((null? it)
(cons (list w h) ret));return this
((= x (string-length (car it)))
(loop 0 (+ y 1) (max x w) (+ h 1) (cdr it) ret))
((equal? (string-ref (car it) x) #\.)
(loop (+ x 1) y w h it ret))
(else
(loop (+ x 1) y w h it
(cons (list (list x y) (string-ref (car it) x)) ret))))))
;;;pos-list
(define (make-pos-list string-list-data)
(define _ (pos-list-of-strs string-list-data))
(define (dispatch message)
(case message
((width)
(lambda () (caar _)))
((height)
(lambda () (cadar _)))
((data-ref)
(lambda ()(cdr _)))
(else (error message))))
(dispatch->callable dispatch))
;;;=====(require 'view2)=====
;;;=====(require 'data)=====
(define (make-state)
(define alist-data (list))
(define (dispatch message)
(case message
((get)
(lambda (key)
(cond ((assoc key alist-data)=>(lambda (x) (cdr x)))(else #f))))
((put)
(lambda (key value)
(let ((ptr (assoc key alist-data)))
(if ptr (set-cdr! ptr value)
(set! alist-data (cons (cons key value) alist-data))))))
((save)
(lambda (file)
(call-with-output-file file
(lambda (port)
(write alist-data port)))))
((load)
(lambda (file)
(call-with-input-file file
(lambda (port)
(let ((sexp (read port)))
(if (eof-object? sexp)
(set! alist-data (list))
(set! alist-data sexp)))))))
(else (error message))))
dispatch)
;;;=====(require 'deprecate)=====
;;;=====(require 'main)=====
;;;make-map-modelA
;;;one map
(define (show-map-scene5)
(define (map-event p x y)
(cond
((assoc (list x y) (filter (lambda (x) (eqv? #\$ (cadr x))) map-objs))
(clrscr)
(display "hello world")
(inkey))
((assoc (list x y) map-objs)
=>(lambda (x) '()))
(else (p 'put x y)))
(map-loop))
(define p (make-movable map-event))
(define budr1 (make-pos-list
'("......................"
".......#.......#......"
"..........#......$...."
".....$................"
".............#........"
"......#..............."
"...............#......"
"........#.....#.......")))
(define map-objs
(cons
(list (p 'position-ref) "@")
(budr1 'data-ref)));map this
(define (map-char-of-pos x y);map-show make this simpler
(let ((lst (assoc-all (list x y) map-objs)));map-objs
(if (not lst) "." (cadr (car lst)))))
(define (map-loop)
(clrscr)
(display "[map]\n")
(map-view-display (budr1 'width) (budr1 'height) map-char-of-pos)
(input-and-move (curry p 'move)))
(map-loop))
(show-map-scene5)
(exit)
参考代码：
http://www.zincland.com/powder/
http://roguebasin.roguelikedevelopment.org
http://users.freebasic-portal.de/rdc/programs.html
http://marijnhaverbeke.nl/dunwich/
http://www.cs.cmu.edu/Groups/AI/lang/scheme/code/fun/advent.scm
等之后有空的时间来安排一个剧本来写完整吧，最近不会继续打理这个了。
上面说的东西是在自娱自乐，能够用来开心一下就目的达成。
