Land of Lisp
(オライリージャパン)
M.D. Conrad Barski (著) 川合 史朗 (翻訳)
原書: Land of LISP
Learn to Program in Lisp, One Game at a Time!
開発環境
- OS X Yosemite - Apple (OS)
- Emacs(Text Editor)
- Scheme (プログラミング言語)
- kscheme, Gauche, MIT/GNU Scheme, GNU Guile (処理系)
Land of Lisp (M.D. Conrad Barski (著)、川合 史朗 (翻訳)、オライリージャパン)の8章(親父のワンプスとは一味違う)、8.4(新しいゲームを始めるために、グランド・セフトワンプスを初期化する)、8.5(シティのマップを描く)を Scheme で取り組んでみる。
8.4(新しいゲームを始めるために、グランド・セフトワンプスを初期化する)、8.5(シティのマップを描く)
コード(Emacs)
;; kscheme の実装の問題か、Scheme のソースコードの問題か、Common Lisp の関数の機能を
;; 誤解してるからか、分からない箇所がふえてきたかも。
;; ということで、kscheme でのエラー処理の実装、もう少ししないと使いにくくなってきたかも。
(begin
(define print (lambda (x) (display x) (newline)))
(define member
(lambda (o items)
(if (null? items)
#f
(let ((item (car items)))
(if (equal? o item)
items
(member o (cdr items)))))))
;; まだ kscheme に load 手続きを実装してない。
;; ということで、直接 graph-util.scm のソースコードを貼り付け
(define odd? (lambda (n) (= (remainder n 2) 1)))
(define zero? (lambda (n) (= n 0)))
(define map
(lambda (proc items)
(if (null? items)
(quote ())
(cons (proc (car items))
(map proc (cdr items))))))
(define for-each
(lambda (proc items)
(if (not (null? items))
(begin (proc (car items))
(for-each proc (cdr items))))))
(define assoc
(lambda (obj alist)
(if (null? alist)
#f
(let ((item (car alist)))
(if (equal? obj (car item))
item
(assoc obj (cdr alist)))))))
(define object->string
(lambda (o)
(cond ((symbol? o) (symbol->string o))
((number? o) (number->string o))
((null? o) "")
((pair? o) (string-append (object->string (car o))
(object->string (cdr o))))
((string? o) o))))
(define substitute-if
(lambda (o pred exp)
(if (string? exp)
(list->string (map (lambda (c1)
(if (pred c1)
o
c1))
(string->list exp)))
(map (lambda (item)
(if (pred item)
o
item))
exp))))
(define complement
(lambda (pred)
(lambda (x)
(not (pred x)))))
(define alphanumeric?
(lambda (x)
(or (char-alphabetic? x)
(char-numeric? x))))
(define dot-name
(lambda (exp)
(substitute-if #\_
(complement alphanumeric?)
(object->string exp))))
(define *max-label-length* 30)
(define substring
(lambda (s start end)
(list->string (string->list s start end))))
(define string-append
(lambda (s1 s2)
(list->string (append (string->list s1)
(string->list s2)))))
(define object->string-1
(lambda (o)
(cond ((null? o) "")
((pair? o)
(string-append (object->string-1 (car o))
(object->string-1 (cdr o))))
(else
(string-append
(cond ((symbol? o) (symbol->string o))
((number? o) (number->string o))
((string? o) o))
" ")))))
(define dot-label
(lambda (exp)
(if exp
(let ((s (object->string-1 exp)))
(if (> (string-length s) *max-label-length*)
(string-append (substring s 0 (- *max-label-length* 3))
"...")
s))
"")))
(define nodes->dot
(lambda (nodes port)
(map (lambda (node)
(newline port)
(display (dot-name (car node)) port)
(display "[label=\"" port)
(display (dot-label node) port)
(display "\"];" port))
nodes)))
(define edges->dot
(lambda (edges port)
(map (lambda (node)
(map (lambda (edge)
(newline port)
(display (dot-name (car node)) port)
(display "->" port)
(display (dot-name (car edge)) port)
(display "[label=\"" port)
(display (dot-label (cdr edge)) port)
(display "\"];" port))
(cdr node)))
edges)))
(define graph->dot
(lambda (nodes edges port)
(display "digraph{" port)
(nodes->dot nodes port)
(edges->dot edges port)
(display "}" port)))
;; Common Lisp と違って、Scheme の仕様に、C言語の system 関数みたいな、
;; 外部スクリプトを実行する手続きがないっぽかった(?)。
;; ということで、kscheme に独自に system 手続きを実装。
;; Gauche には、C言語の exec 関数に相当する、sys-exec 等の手続き、
;; Guile には system 手続きがあった。
(define dot->png
(lambda (fname proc)
(proc)
(system (string-append "dot -Tpng -O " fname))))
(define graph->png
(lambda (fname nodes edges)
(dot->png fname
(lambda ()
(let ((out-file (open-output-file fname)))
(graph->dot nodes edges out-file)
(close-output-port out-file))))))
(define maplist
(lambda (proc items)
(if (not (null? items))
(begin (proc items)
(maplist proc (cdr items))))))
(define uedges->dot
(lambda (edges port)
(maplist (lambda (items)
(map (lambda (edge)
(if (not (assoc (car edge) (cdr items)))
(begin (newline port)
(display (dot-name (caar items)) port)
(display "--" port)
(display (dot-name (car edge)) port)
(display "[label=\"" port)
(display (dot-label (cdr edge)) port)
(display "\"];" port))))
(cdar items)))
edges)))
(define ugraph->dot
(lambda (nodes edges port)
(display "graph{" port)
(nodes->dot nodes port)
(uedges->dot edges port)
(display "}" port)))
(define ugraph->png
(lambda (fname nodes edges)
(dot->png fname
(lambda ()
(let ((out-file (open-output-file fname)))
(ugraph->dot nodes edges out-file)
(close-output-port out-file))))))
(define *congestion-city-nodes* (quote ()))
(define *congestion-city-edges* (quote ()))
(define *player-pos* (quote ()))
(define *visited-nodes* (quote ()))
(define *node-num* 30)
(define *edge-num* 45)
(define *worm-num* 3)
(define *cop-odds* 15)
;; random は仕様にないっぽい(？)
;; kscheme には gmp (gnu multi-precision library) を利用して実装
;; Scheme Requests for Implementation (SRFI)にあるのかも
(define random-node
(lambda ()
(+ (random *node-num*) 1)))
(define edge-pair
(lambda (a b)
(if (not (equal? a b))
(list (cons a b)
(cons b a)))))
;; Common Lisp の loop コマンドは、Scheme にはないっぽい。
;; ということで、再帰手続きで同様の機能を定義
(define make-edge-list
(lambda ()
(define iter
(lambda (n)
(if (= n 0)
(quote ())
(cons (edge-pair (random-node)
(random-node))
(iter (- n 1))))))
(apply append (iter *edge-num*))))
(define repeat
(lambda (x n)
(if (= n 0)
(quote ())
(cons x (repeat x (- n 1))))))
(define enumerate-interval
(lambda (low high)
(if (> low high)
(quote ())
(cons low
(enumerate-interval (+ low 1) high)))))
(define remove-if-not
(lambda (pred items)
(cond ((null? items) (quote ()))
((pred (car items))
(cons (car items)
(remove-if-not pred (cdr items))))
(else (remove-if-not pred (cdr items))))))
(define direct-edges
(lambda (node edge-list)
(remove-if-not (lambda (x)
(equal? (car x) node))
edge-list)))
;; (define push
;; (lambda (o items)
;; (let ((t (map (lambda (x) x) items)))
;; (set-car! items o)
;; (set-cdr! items t)
;; items)))
(define get-connected
(lambda (node edge-list)
(let ((visited (quote ())))
(define traverse
(lambda (node)
(if (not (member node visited))
(begin ;; (push node visited)
(set! visited (cons node visited))
(map (lambda (edge)
(traverse (cdr edge)))
(direct-edges node edge-list))))))
(traverse node)
visited)))
;; Common Lisp にはあって、Scheme にはない set-difference 手続きを定義
(define set-difference
(lambda (set1 set2)
(cond ((null? set1) (quote ()))
((null? set2) set1)
((member (car set1) set2)
(set-difference (cdr set1) set2))
(else (cons (car set1)
(set-difference (cdr set1) set2))))))
;; kscheme に let* を実装してないから、let で同様の機能をもつ手続きを定義
(define find-islands
(lambda (nodes edge-list)
(let ((islands (quote ())))
(define find-island
(lambda (nodes)
(let ((connected (get-connected (car nodes) edge-list)))
(let ((unconnected (set-difference nodes connected)))
;; (push connected islands)
(set! islands (cons connected islands))
(if (not (null? unconnected))
(find-island unconnected))))))
(find-island nodes)
islands)))
(define connect-with-bridges
(lambda (islands)
(if (not (null? (cdr islands)))
(append (edge-pair (caar islands)
(caadr islands))
(connect-with-bridges (cdr islands)))
(quote ()))))
(define connect-all-islands
(lambda (nodes edge-list)
(append (connect-with-bridges (find-islands nodes edge-list))
edge-list)))
(define make-city-edges
(lambda ()
(let ((nodes (enumerate-interval 1 *node-num*)))
(let ((edge-list (connect-all-islands nodes (make-edge-list))))
(let ((cops (remove-if-not (lambda (x)
(zero? (random *cop-odds*)))
edge-list)))
(add-cops (edges-to-alist edge-list) cops))))))
(define remove-duplicates
(lambda (items)
(cond ((null? items) (quote ()))
((member (car items) (cdr items))
(remove-duplicates (cdr items)))
(else (cons (car items)
(remove-duplicates (cdr items)))))))
(define edges-to-alist
(lambda (edge-list)
(map (lambda (node1)
(cons node1
(map (lambda (edge)
(list (cdr edge)))
(remove-duplicates (direct-edges node1 edge-list)))))
(remove-duplicates (map car edge-list)))))
(define intersection
(lambda (set1 set2)
(define iter
(lambda (s1 s2 result)
(cond ((or (null? s1) (null? s2)) result)
((and (member (car s1) s2)
(not (member (car s1) result)))
(iter (cdr s1) s2 (cons (car s1) result)))
(else (iter (cdr s1) s2 result)))))
(iter set1 set2 (quote ()))))
(define add-cops
(lambda (edge-alist edges-with-cops)
(map (lambda (x)
(let ((node1 (car x))
(node1-edges (cdr x)))
(cons node1
(map (lambda (edge)
(let ((node2 (car edge)))
(if (not (null? (intersection (edge-pair node1
node2)
edges-with-cops)))
(list node2 (quote cops))
edge)))
node1-edges))))
edge-alist)))
(define neighbors
(lambda (node edge-alist)
(let ((edge (assoc node edge-alist)))
(if edge
(map car (cdr edge))
(quote ())))))
(define within-one
(lambda (a b edge-alist)
(member b (neighbors a edge-alist))))
;; Common Lisp の some 手続きが、Scheme にはなかった。
;; 同様の機能の手続きを定義
(define some
(lambda (pred items)
(cond ((null? items) #f)
((pred (car items)) #t)
(else (some pred (cdr items))))))
(define within-two
(lambda (a b edge-alist)
(or (within-one a b edge-alist)
(some (lambda (x)
(within-one x b edge-alist))
(neighbors a edge-alist)))))
(define make-city-nodes
(lambda (edge-alist)
(let ((wumpus (random-node))
(glow-worms (map (lambda (x) (random-node))
(enumerate-interval 1 *worm-num*))))
(map (lambda (n)
(append (list n)
(cond ((equal? n wumpus) (quote (wumpus)))
((within-two n wumpus edge-alist) (quote (blood!)))
(else (quote ())))
(cond ((member n glow-worms) (quote (glow-worm)))
((some (lambda (worm)
(within-one n worm edge-alist))
glow-worms)
(quote (lights!)))
(else (quote ())))
(let ((edge (assoc n edge-alist)))
, (if edge
(if (some (lambda (x) (not (null? (cdr x))))
(cdr edge))
(quote (sirens!))
(quote ()))
(quote ())))))
(enumerate-interval 1 *node-num*)))))
(define new-game
(lambda ()
(set! *congestion-city-edges* (make-city-edges))
(set! *congestion-city-nodes* (make-city-nodes *congestion-city-edges*))
(set! *player-pos* (find-empty-node))
(set! *visited-nodes* (list *player-pos*))
(draw-city)))
(define find-empty-node
(lambda ()
(let ((x (random-node)))
(if (null? (cdr (assoc x *congestion-city-nodes*)))
x
(find-empty-node)))))
(define draw-city
(lambda ()
(print *congestion-city-nodes*)
(print *congestion-city-edges*)
(ugraph->png "city" *congestion-city-nodes* *congestion-city-edges*)))
(new-game)
(quote done))
入出力結果(Terminal(kscheme), REPL(Read, Eval, Print, Loop))
$ kscheme sample4.scm ((1 blood!) (2 blood! lights! sirens!) (3) (4 blood! sirens!) (5 lights!) (6 sirens!) (7 blood!) (8 blood! glow-worm) (9 wumpus glow-worm sirens!) (10 sirens!) (11 sirens!) (12) (13) (14 sirens!) (15 sirens!) (16 sirens!) (17 blood!) (18) (19) (20) (21 sirens!) (22 lights! sirens!) (23 sirens!) (24 blood! lights!) (25 blood! glow-worm) (26 blood! lights!) (27) (28 blood!) (29 blood! lights!) (30 blood! lights!)) ((18 (5)) (5 (18) (25)) (16 (4 cops) (12) (22)) (22 (23 cops) (16) (8)) (3 (7)) (7 (3) (24)) (28 (30) (17) (27)) (27 (19) (28)) (26 (9)) (15 (21) (4 cops)) (4 (16 cops) (10 cops) (29) (17) (15 cops) (23)) (23 (22 cops) (6) (4)) (14 (11 cops) (12)) (13 (20)) (1 (24) (29)) (17 (28) (24) (4) (12)) (12 (21) (16) (11) (14) (17)) (30 (28) (9)) (8 (22) (2)) (2 (9 cops) (8)) (21 (12) (6) (15) (10 cops)) (10 (4 cops) (20) (21 cops)) (24 (17) (9) (7) (1) (25)) (25 (5) (24)) (6 (21) (23) (11 cops)) (11 (14 cops) (19) (12) (6 cops)) (9 (2 cops) (24) (26) (30) (29)) (29 (4) (1) (9)) (19 (27) (11) (20)) (20 (10) (13) (19))) done $ open city.png $
DOT ファイルから、Graphviz を使って得た無向グラフ。
0 コメント:
コメントを投稿