Scheme:Brainfuck:別解

Scheme:Brainfuck:別解

別解その1

SICP読んだばかりですバージョン

      1 #! /usr/local/bin/gosh
      2 ; $Id$
      3 ; cut-sea.
      4
      5 ;; 範囲制御付きポインタ
      6 (define (make-pointer min max)
      7   (let ((reg min))
      8     (define (set v)
      9       (if (and (>= v min) (< v max))
     10           (set! reg v)
     11           (else (error "ERROR: pointer position out of area." v))))
     12     (define (get)
     13       reg)
     14     (define (init)
     15       (set! reg min))
     16     (define (dispatch m)
     17       (cond ((eq? m 'set) set)
     18             ((eq? m 'get) (get))
     19             ((eq? m 'init) (init))
     20             (else (error "ERROR: No such operation for pointer." m))))
     21     dispatch))
     22
     23 (define (set-pointer p v) ((p 'set) v))
     24 (define (get-pointer p) (p 'get))
     25 (define (init-pointer p) (p 'init))
     26
     27 ;; スタック
     28 (define (make-stack)
     29   (let ((stack '()))
     30     (define (push v)
     31       (set! stack (cons v stack)))
     32     (define (pop)
     33       (if (not (null? stack))
     34           (let ((v (car stack)))
     35             (set! stack (cdr stack))
     36             v)
     37           (error "ERROR: stack has no value.")))
     38     (define (peek)
     39       (if (not (null? stack))
     40           (car stack)
     41           (error "ERROR: stack has no value.")))
     42     (define (check)
     43       stack)
     44     (define (init)
     45       (set! stack '()))
     46     (define (dispatch m)
     47       (cond ((eq? m 'push) push)
     48             ((eq? m 'pop) (pop))
     49             ((eq? m 'peek) (peek))
     50             ((eq? m 'check) (check))
     51             ((eq? m 'init) (init))
     52             (else (error "ERROR: No such operation for stack." m))))
     53     dispatch))
     54
     55 (define (push s v) ((s 'push) v))
     56 (define (pop s) (s 'pop))
     57 (define (peek s) (s 'peek))
     58 (define (check-stack s) (s 'check)) ;for debug
     59 (define (init-stack s) (s 'init))
     60
     61 ;; テープメモリ
     62 (define (make-tape size)
     63   (letrec ((min 0)
     64            (max size)
     65            (tape (make-vector max 0)))
     66     (define (set p v)
     67       (if (and (>= p min) (< p max))
     68           (begin
     69             (vector-set! tape p v)
     70             v)
     71           (error "ERROR: tape area overflow." p)))
     72     (define (get p)
     73       (if (and (>= p min) (< p max))
     74           (vector-ref tape p)
     75           (else "ERROR: tape area overflow." p)))
     76     (define (check)
     77       tape)
     78     (define (init)
     79       (set! tape (make-vector max 0)))
     80     (define (dispatch m)
     81       (cond ((eq? m 'set) set)
     82             ((eq? m 'get) get)
     83             ((eq? m 'check) (check))
     84             ((eq? m 'init) (init))
     85             (else (error "ERROR: No such operation for stack." m))))
     86     dispatch))
     87
     88 (define (store-value t p v) ((t 'set) p v))
     89 (define (load-value t p) ((t 'get) p))
     90 (define (check-value t) (t 'check))
     91 (define (init-tape t) (t 'init))
     92
     93 ;; まず単純にコードを読み込み逆順リストにする
     94 ;; +-><[]., => (#\, #\. #\] #\[ #\< #\> #\- #\+)
     95 ;;
     96 (define (read-text source-text)
     97   (let ((code '())
     98         (text source-text)) ;; source-text はソースコードのポート
     99
    100     (let loop ((c (read-char text)))
    101       (if (eof-object? c)
    102           code
    103           (case c
    104             ((#\+ #\- #\< #\> #\. #\, #\[ #\] #\?)
    105              (begin
    106                (set! code (cons c code))
    107                (loop (read-char text))))
    108             (else (loop (read-char text))))))))
    109
    110 ;; read-text の返り値の逆順リストを reverse しつつ
    111 ;; #\[ #\] を読み込んだときに対応を取り込んでおく
    112 ;; その情報を組み込んだ内部命令コードリストを返す
    113 ;; 要は #\[ でポインタ下のテープのデータが 0 の時の
    114 ;; ジャンプ先をとらえておくもの
    115 ;;
    116 (define (reverse-text code-list)
    117   (let ((insts (list 'done))
    118         (stack (make-stack)))
    119
    120     (let loop ((code code-list))
    121       (if (null? code)
    122           insts
    123           (let ((c (car code)))
    124             (begin
    125               (case c
    126                 ((#\+) (set! insts
    127                              (cons 'incre insts)))
    128                 ((#\-) (set! insts
    129                              (cons 'decre insts)))
    130                 ((#\<) (set! insts
    131                              (cons 'lshif insts)))
    132                 ((#\>) (set! insts
    133                              (cons 'rshif insts)))
    134                 ((#\.) (set! insts
    135                              (cons 'prout insts)))
    136                 ((#\,) (set! insts
    137                              (cons 'getch insts)))
    138                 ((#\[) (set! insts
    139                              (cons (cons 'branch (pop stack)) insts)))
    140                 ((#\]) (begin
    141                          (push stack insts)
    142                          (set! insts (cons 'windbk insts))))
    143                 ((#\?) (set! insts
    144                              (cons 'infom insts))))
    145               (loop (cdr code))))))))
    146
    147
    148 ;;
    149 (define (make-vm inport outport tape-size)
    150   (let ((pc '())
    151         (insts '())
    152         (sp (make-stack))
    153         (pointer (make-pointer 0 tape-size))
    154         (tape (make-tape tape-size)))
    155
    156
    157     ;; 内部命令セット
    158     (define (incre)
    159       (letrec ((p (get-pointer pointer))
    160                (v (load-value tape p)))
    161         (store-value tape p (inc! v))))
    162
    163     (define (decre)
    164       (letrec ((p (get-pointer pointer))
    165                (v (load-value tape p)))
    166         (store-value tape p (dec! v))))
    167
    168     (define (lshif)
    169       (let ((p (get-pointer pointer)))
    170         (set-pointer pointer (dec! p))))
    171
    172     (define (rshif)
    173       (let ((p (get-pointer pointer)))
    174         (set-pointer pointer (inc! p))))
    175
    176     (define (prout)
    177       (letrec ((p (get-pointer pointer))
    178                (v (load-value tape p)))
    179         (write-byte v outport)
    180         (flush)))
    181
    182     (define (getch)
    183       (letrec ((p (get-pointer pointer))
    184                (v #t))
    185         (set! v (read-byte inport))
    186         (store-value tape p v)))
    187
    188     (define (branch cont)
    189       (letrec ((p (get-pointer pointer))
    190                (v (load-value tape p)))
    191         (if (eq? v 0)
    192             (set! pc (cons 'nop cont))
    193             (push sp pc))))
    194
    195     (define (windbk)
    196       (set! pc (cons 'nop (pop sp))))
    197
    198     (define (nop)
    199       (format #t "no operation."))
    200
    201     (define (done)
    202       (format #t "Program reach end..."))
    203
    204     ;; 外部インターフェース用
    205     (define (load code)
    206       (begin
    207         (init-stack sp)
    208         (init-pointer pointer)
    209         (init-tape tape)
    210         (set! pc code)
    211         (set! insts code)
    212         'ok))
    213
    214     (define (execute inst)
    215       (if (pair? inst)
    216           (if (eq? (car inst) 'branch)
    217               (branch (cdr inst))
    218               (error "ERROR: Here is expected branch operation."))
    219           (cond ((eq? inst 'incre) (incre))
    220                 ((eq? inst 'decre) (decre))
    221                 ((eq? inst 'lshif) (lshif))
    222                 ((eq? inst 'rshif) (rshif))
    223                 ((eq? inst 'prout) (prout))
    224                 ((eq? inst 'getch) (getch))
    225                 ((eq? inst 'windbk) (windbk))
    226                 ((eq? inst 'done) 'done)      ; no message.
    227                 ((eq? inst 'nop) (nop))
    228                 ((eq? inst 'infom) (infom))
    229                 (else (error "ERROR: Invalid instruction code.")))))
    230
    231     (define (run)
    232       (if (not (null? pc))
    233           (begin
    234             (execute (car pc))
    235             (set! pc (cdr pc))
    236             (run))
    237           'done))
    238
    239     (define (infom)
    240       (begin
    241         (format #t "program counter   : ~a~%" pc)
    242         (format #t "stack pointer     : ~a~%" (check-stack sp))
    243         (format #t "the pointer       : ~a~%" (get-pointer pointer))
    244         (format #t "pointed value     : ~a~%" (load-value tape (get-pointer pointer)))
    245         (format #t "loading program   : ~a~%" insts)
    246         'ok))
    247
    248     (define (dispatch m)
    249       (cond ((eq? m 'load) load)
    250             ((eq? m 'run) (run))
    251             ((eq? m 'infom) (infom))
    252             (else (error "ERROR: It's invalid instruction for brainfuck virtual machine -- " m))))
    253     dispatch))
    254
    255 (define (compile-load vm inport) ((vm 'load) (reverse-text (read-text inport))))
    256 (define (loading vm code) ((vm 'load) code))
    257 (define (run vm) (vm 'run))
    258 (define (vminfo vm) (vm 'infom))
    259
    260 ;; メイン
    261 (define (main args)
    262   (with-error-handler
    263    (lambda (err) (format (current-error-port) "ERROR: ~a~%" (slot-ref err 'message)))
    264    (lambda ()
    265      (if (not (null? (cdr args)))
    266          (let ((in (current-input-port))
    267                (out (current-output-port)))
    268            (begin
    269              (define bfm (make-vm in out 30000))
    270              (define src (open-input-file (cadr args)))
    271              (compile-load bfm src)
    272              (run bfm)))
    273          (begin
    274            (format #t "usage: bf.scm filename~%")
    275            (format #t "       <filename> -- brainfuck source code~%"))))))
    276
    277
    278 ;; お試しコード埋め込み
    279
    280 ;; Hello, World プログラム
    281 ;(define str (open-input-string "
    282 ;>+++++++++[<++++++++>-]<.>+++++++[<++++>-]<+.+++++++..+++.[-]>++++++++[<++++>-]
    283 ;<.>+++++++++++[<+++++>-]<.>++++++++[<+++>-]<.+++.------.--------.[-]>++++++++[
    284 ;<++++>-]<+.[-]++++++++++.
    285 ;"))
    286 ;(define b (make-vm (current-input-port) (current-output-port) 30000))
    287 ;(compile-load b str)
    288 ;(run b)
    289
    290 ;; echo プログラム
    291 ;(define str (open-input-string "
    292 ;+[>,.<]
    293 ;"))
    294 ;(define b (make-vm (current-input-port) (current-output-port) 30000))
    295 ;(compile-load b str)
    296 ;(run b)
More ...