fork download
copy 
  1. #lang racket
  2.  
  3. ;; シナリオのロード
  4.  
  5. (define *scenario*
  6.   (with-input-from-file "img8/scenario-rkt.txt"
  7.     (lambda ()
  8.       (let loop ((s-expression (read)) (acc '()))
  9.         (if (eof-object? s-expression)
  10.            (reverse acc)
  11.            (loop (read) (cons s-expression acc)))))))
  12.  
  13. ;; 初期メッセージ
  14.  
  15. (define *init-message* "Enterでスタート")
  16.  
  17. ;;; 終了メッセージ
  18.  
  19. (define *end-message* "終わり")
  20.  
  21. ;; World 構造体
  22.  
  23. (struct world
  24.   (back branches characters color message scenario)
  25.   #:transparent)
  26.  
  27. ;; eval
  28.  
  29. (define (world-go exp w)
  30.   (let loop ((back (world-back w))
  31.              (branches (world-branches w))
  32.              (characters (world-characters w))
  33.              (color (world-color w))
  34.              (message (world-message w))
  35.              (scenario (world-scenario w)))
  36.     (let ((s-expression (car scenario)))
  37.       (let ((head (car s-expression)) (tail (cdr s-expression)))
  38.         (case head
  39.           ((back) (loop (car tail) branches characters
  40.                        color message (cdr scenario)))
  41.           ((branch) (loop back (cons tail branches) characters
  42.                          color message (cdr scenario)))
  43.           ((break) (cond ((or (char=? exp #\1)
  44.                              (char=? exp #\2))
  45.                           (world-go #\newline
  46.                                    (world back '() characters
  47.                                          color message
  48.                                          (find-label
  49.                                           (third
  50.                                            (assv (digit-value exp)
  51.                                                 branches))
  52.                                           scenario))))
  53.                         ((or (char=? exp #\y)
  54.                             (char=? exp #\n))
  55.                          (world-go #\newline
  56.                                   (world back '() characters
  57.                                         color message
  58.                                         (find-label
  59.                                          (second
  60.                                           (assoc (list->string `(,exp))
  61.                                                 (map reverse branches)))
  62.                                          scenario))))
  63.                         (else (world back branches characters
  64.                                     color message scenario))))
  65.           ((end) (world back branches characters
  66.                        color *end-message* scenario))
  67.           ((jump) (world-go #\newline
  68.                            (world back branches characters
  69.                                  color message
  70.                                  (find-label (car tail) scenario))))
  71.           ((label) (world back branches characters
  72.                          color message (cons '(break) scenario)))
  73.           ((msg) (world back branches characters
  74.                        color (car tail) (if (char=? exp #\newline)
  75.                                            (cdr scenario)
  76.                                            scenario)))
  77.           ((putChar) (loop back branches
  78.                           (if (member tail characters)
  79.                              characters
  80.                              (cons tail characters))
  81.                           color message (cdr scenario)))
  82.           (else (error "Can't do " head)))))))
  83.  
  84. ;; 補助関数  
  85. (define (digit-value ch)
  86.   (string->number (list->string `(,ch))))
  87.  
  88. (define (find-label x scenario)
  89.   (unless (null? scenario)
  90.     (let ((s-expression (car scenario)))
  91.       (let ((head (car s-expression)) (tail (cdr s-expression)))
  92.         (if (and (eq? head 'label) (eq? x (car tail)))
  93.            (cdr scenario)
  94.            (find-label x (cdr scenario)))))))
  95.  
  96. ;;; ゲーム終了条件
  97. (define (game-ends? w)
  98.   (string=? (world-message w) *end-message*))
  99.  
  100. ;;; 出力関数                
  101. (define (print w)
  102.   (display
  103.    (format "~a~%" (if (null? (world-branches w))
  104.                      (string-replace (world-message w) "~%" "\n")
  105.                      (apply string-append
  106.                            (map (lambda (x)
  107.                                   (string-append
  108.                                    (number->string (car x))
  109.                                    " "
  110.                                    (second x)
  111.                                    "\n"))
  112.                                (reverse (world-branches w))))))))
  113.  
  114. ;;; REPL(Read-Eval-Print Loop)
  115.  
  116. (define (repl w)
  117.   (print w)
  118.   (if (game-ends? w)
  119.      (exit)
  120.      (repl (world-go (read-char) w))))
  121.  
  122. (repl (world #f '() '() 1 *init-message* *scenario*))
Success #stdin #stdout 0.74s 114960KB
comments (?)
stdin
copy 
Standard input is empty
stdout
copy 
Standard output is empty
https://ideone.com/WX4JF3
language:
Racket (racket 7.0)
created:
2 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!