PageRenderTime 48ms CodeModel.GetById 20ms RepoModel.GetById 0ms app.codeStats 0ms

/src/web/examples/slbrainfuck.lsp

http://substandard-lisp.googlecode.com/
Lisp | 73 lines | 64 code | 9 blank | 0 comment | 0 complexity | 199dbd7854a0b298ad3e36e757e473fa MD5 | raw file
    

  1. % slbrainfuck - substandard lisp brainfuck interpreter
    2. 

  2. % author: Nicky Nickell <nicky.nickell@gmail.com>
    3. 

  3. 

  4. (setq *OUTPUT nil)
    5. 

  5. (setq helloworld "++++++++++[>+++++++>++++++++++>+++>+<<<<-]>++.>+.+++++++..+++.>++.<<+++++++++++++++.>.+++.------.--------.>+.>.")
    6. 

  6. 

  7. (de range (start end)
    8. 

  8.   (cond ((greaterp start end)
    9. 

  9.          (cond ((eqn start end) (cons end nil))
    10. 

  10.                (t (cons start (range (sub1 start) end)))))
    11. 

  11.         (t
    12. 

  12.          (cond ((eqn start end) (cons end nil))
    13. 

  13.                (t (cons start (range (add1 start) end)))))))
    14. 

  14. 

  15. (de bfseek (bfp from direction for)
    16. 

  16.   (prog nil
    17. 

  17.     (mapc (if (minusp direction) 
    18. 

  18.             (range 0 from)
    19. 

  19.             (range from (length bfp)))
    20. 

  20.       (lambda (i)
    21. 

  21.         (if (eqn (nth i bfp) for) (return i))))))
    22. 

  22. 

  23. (de bf (bfp bfi)
    24. 

  24.   (let ((ptr 0)
    25. 

  25.         (pc 0)
    26. 

  26.         (bfout nil)
    27. 

  27.         (memory (make-vector 200 0))
    28. 

  28.         (bfin (string-to-list bfi))
    29. 

  29.         (bfprog (string-to-list bfp)))
    30. 

  30.     (prog (op)
    31. 

  31. top   (setq op (nth pc bfprog))
    32. 

  32.       (cond ((eqn op (char !>))
    33. 

  33.              (setq ptr (add1 ptr)))
    34. 

  34.             ((eqn op (char !<)) 
    35. 

  35.              (setq ptr (sub1 ptr)))
    36. 

  36.             ((eqn op (char !+))
    37. 

  37.              (vector-store memory ptr (add1 (vector-fetch memory ptr))))
    38. 

  38.             ((eqn op (char !-))
    39. 

  39.              (vector-store memory ptr (sub1 (vector-fetch memory ptr))))
    40. 

  40.             ((eqn op (char !.))
    41. 

  41.              (push (vector-fetch memory ptr) bfout))
    42. 

  42.             ((eqn op (char !,))
    43. 

  43.              (vector-store memory ptr (pop bfin)))
    44. 

  44.             ((eqn op (char ![))
    45. 

  45.              (if (zerop (vector-fetch memory ptr))
    46. 

  46.                (setq pc (bfseek bfprog pc 1 (char !])))))
    47. 

  47.             ((eqn op (char !]))
    48. 

  48.              (if (zerop (vector-fetch memory ptr))
    49. 

  49.                nil
    50. 

  50.                (setq pc (bfseek bfprog pc -1 (char ![)))))
    51. 

  51.             ((null op)
    52. 

  52.              (return nil)))
    53. 

  53.         (setq pc (add1 pc))
    54. 

  54.         (go top))
    55. 

  55. 

  56.     (if (null bfout)
    57. 

  57.       ""
    58. 

  58.       (list2string (reverse bfout)))))
    59. 

  59. 

  60. (de bfeval nil
    61. 

  61.   (dom-append (dom-get-element-by-id "out") "output: <br>"
    62. 

  62.     (bf (dom-get-value (dom-get-element-by-id "program"))
    63. 

  63.         (dom-get-value (dom-get-element-by-id "input"))) "<br>"))
    64. 

  64. 

  65. (dom-set-title "slbrainfuck")
    66. 

  66. 

  67. (dom-append (dom-get-body) 
    68. 

  68.   "program: " (dom-create-text '(("id" . "program"))) "<br>"
    69. 

  69.   "input: " (dom-create-text '(("id" . "input"))) "<br>"
    70. 

  70.   (dom-create-button "execute" nil '(("onclick" . (bfeval)))) "<br>"
    71. 

  71.   (dom-create "div" '(("id" . "out"))))
    72. 

    73. 

  73. (dom-set-attribute (dom-get-element-by-id "program") "value" helloworld)
    74. 

  74.