fork download 
  1. #lang racket/gui
  2.  
  3. (require srfi/13 srfi/14)
  4.  
  5. (define *nodes* '((居間 (あなたは魔法使いの館の居間にいる。魔法使いはソファでいびきをかいている。))
  6.                   (庭 (あなたは美しい庭にいる。目の前に井戸がある。))
  7.                   (屋根裏 (あなたは屋根裏にいる。部屋の隅に巨大な溶接バーナーがある。))))
  8.  
  9. (define (describe-location location nodes)
  10.   (second (assq location nodes)))
  11.  
  12. (define *edges* '((居間 (庭 西 に向かう ドア)
  13.                      (屋根裏 上 に続く 梯子))
  14.                   (庭 (居間 東 に向かう ドア))
  15.                   (屋根裏 (居間 下 に続く 梯子))))
  16.  
  17. (define (describe-path edge)
  18.   `(ここから ,(second edge) ,(third edge) ,(fourth edge) がある。))
  19.  
  20. (define (describe-paths location edges)
  21.   (apply append (map describe-path (cdr (assq location edges)))))
  22.  
  23. (define *objects* '(ウィスキー バケツ カエル 鎖))
  24.  
  25. (define *object-locations* '((ウィスキー 居間)
  26.                              (バケツ 居間)
  27.                              (鎖 庭)
  28.                              (カエル 庭)))
  29.  
  30. (define (objects-at loc objs obj-locs)
  31.   (letrec ((at-loc? (lambda (obj)
  32.                       (eq? (second (assq obj obj-locs)) loc))))
  33.     (filter at-loc? objs)))
  34.  
  35. (define (describe-objects loc objs obj-loc)
  36.   (letrec ((describe-obj (lambda (obj)
  37.                            `(床に ,obj がある。))))
  38.     (apply append (map describe-obj (objects-at loc objs obj-loc)))))
  39.  
  40. (define *location* '居間)
  41.  
  42. (define (look)
  43.   (append (describe-location *location* *nodes*)
  44.          (describe-paths *location* *edges*)
  45.          (describe-objects *location* *objects* *object-locations*)))
  46.  
  47. (define (walk direction)
  48.   (letrec ((correct-way (lambda (edge)
  49.                           (eq? (second edge) direction))))
  50.     (let ((next (findf correct-way (cdr (assq *location* *edges*)))))
  51.       (if next
  52.          (begin (set! *location* (car next))
  53.                (look))
  54.          '(そちらには行けない。)))))
  55.  
  56. (define (pickup object)
  57.   (cond ((memq object (objects-at *location* *objects* *object-locations*))
  58.          (set! *object-locations* (cons `(,object body) *object-locations*))
  59.          `(あなたは ,object を持っている。))
  60.        (else '(それは持てない。))))
  61.  
  62. (define (inventory)
  63.   (cons 'アイテム- (objects-at 'body *objects* *object-locations*)))
  64.  
  65. (define (have object)
  66.   (memq object (cdr (inventory))))
  67.  
  68. (define (game-repl)
  69.   (let ((cmd (game-read)))
  70.     (unless (eq? (car cmd) 'quit)
  71.       (game-print (game-eval cmd))
  72.       (game-repl))))
  73.  
  74. (define (game-read)
  75.   (let ((cmd (read (open-input-string (string-append "(" (read-line) ")")))))
  76.     (let ((quote-it (lambda (x)
  77.       `(quote ,x))))
  78.     (cons (car cmd) (map quote-it (cdr cmd))))))
  79.  
  80. (define *allowed-commands* '((見る . look) (歩く . walk) (拾う . pickup) (持ち物 . inventory)))
  81.  
  82. (define (game-eval sexp)
  83.   (if (memq (car sexp) (map car *allowed-commands*))
  84.      (eval `(,(cdr (assq (car sexp) *allowed-commands*)) ,@(cdr sexp)))
  85.      '(そんなコマンドは知らない。)))
  86.  
  87. (define (tweak-text lst caps lit)
  88.   (let loop ((item (car lst)) (rst (cdr lst)) (caps caps) (lit lit) (acc '()))
  89.     (cond
  90.       ((null? rst) (reverse acc))
  91.       ((char=? item #\space) (loop (car rst) (cdr rst) caps lit acc))
  92.       ((memq item '(#\! #\? #\。)) (loop (car rst) (cdr rst) #t lit (cons item acc)))
  93.       ((char=? item #\") (loop (car rst) (cdr rst) caps (not lit) acc))
  94.       (lit (loop (car rst) (cdr rst) #f lit (cons item acc)))
  95.       (caps (loop (car rst) (cdr rst) #f lit (cons item acc)))
  96.       (else (loop (car rst) (cdr rst) #f #f (cons item acc))))))
  97.  
  98. (define (game-print lst)
  99.   (display (list->string (tweak-text (string->list (string-trim (format "~a" lst) (char-set-adjoin char-set:whitespace #\( #\)))) #t #f)))
  100.   (newline))
Success #stdin #stdout 0.69s 104024KB
comments (?)
stdin 
Standard input is empty
stdout 
Standard output is empty
https://ideone.com/Ljhq1i
language:
Racket (racket 7.0)
created:
3 years ago
visibility:
public

Share or Embed source code

Discover > Sphere Engine API

The brand new service which powers Ideone!

Discover > IDE Widget

Widget for compiling and running the source code in a web browser!