Advertisement
Void-voiD

Untitled

Dec 9th, 2018
171
0
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
text 7.27 KB | None | 0 0
  1. (define-syntax trace
  2. (syntax-rules ()
  3. ((trace x)
  4. (begin
  5. (write (quote x))
  6. (display " => ")
  7. (write x)
  8. (newline)
  9. x))))
  10.  
  11. (define (make-source s . end)
  12. (if (string? s)
  13. (if (null? end)
  14. (let ((static (reverse (cons #f (reverse (string->list s))))))
  15. (lambda (x)
  16. (if (= (length static) 1)
  17. (car static)
  18. (if (equal? x 'peek)
  19. (car static)
  20. (if (equal? x 'next)
  21. (begin
  22. (let ((cur (car static)))
  23. (begin
  24. (set! static (cdr static))
  25. cur)))
  26. static)))))
  27. (let ((static (reverse (cons (car end) (reverse (string->list s))))))
  28. (lambda (x)
  29. (if (= (length static) 1)
  30. (car static)
  31. (if (equal? x 'peek)
  32. (car static)
  33. (if (equal? x 'next)
  34. (begin
  35. (let ((cur (car static)))
  36. (begin
  37. (set! static (cdr static))
  38. cur)))
  39. static))))))
  40. (if (vector? s)
  41. (if (null? end)
  42. (let ((static (reverse (cons #f (reverse (vector->list s))))))
  43. (lambda (x)
  44. (if (= (length static) 1)
  45. (car static)
  46. (if (equal? x 'peek)
  47. (car static)
  48. (if (equal? x 'next)
  49. (begin
  50. (let ((cur (car static)))
  51. (begin
  52. (set! static (cdr static))
  53. cur)))
  54. static)))))
  55. (let ((static (reverse (cons (car end) (reverse (vector->list s))))))
  56. (lambda (x)
  57. (if (= (length static) 1)
  58. (car static)
  59. (if (equal? x 'peek)
  60. (car static)
  61. (if (equal? x 'next)
  62. (begin
  63. (let ((cur (car static)))
  64. (begin
  65. (set! static (cdr static))
  66. cur)))
  67. static))))))
  68. (if (null? end)
  69. (let ((static (reverse (cons #f (reverse s)))))
  70. (lambda (x)
  71. (if (= (length static) 1)
  72. (car static)
  73. (if (equal? x 'peek)
  74. (car static)
  75. (if (equal? x 'next)
  76. (begin
  77. (let ((cur (car static)))
  78. (begin
  79. (set! static (cdr static))
  80. cur)))
  81. static)))))
  82. (let ((static (reverse (cons (car end) (reverse s)))))
  83. (lambda (x)
  84. (if (= (length static) 1)
  85. (car static)
  86. (if (equal? x 'peek)
  87. (car static)
  88. (if (equal? x 'next)
  89. (begin
  90. (let ((cur (car static)))
  91. (begin
  92. (set! static (cdr static))
  93. cur)))
  94. static)))))))))
  95.  
  96. (define (peek x)
  97. (x 'peek))
  98.  
  99. (define (next x)
  100. (x 'next))
  101.  
  102. ;expr ::= letters numbers sk operations | .
  103. ;letters ::= letter | .
  104. ;numbers ::= <0> | <1> | <2> | <3> | <4> | <5> | <6> | <7> | <8> | <9> .
  105. ;sk ::= <(> | <)> | < > | .
  106.  
  107. (define-syntax use-assertions
  108. (syntax-rules ()
  109. ((_) (eval '(define exit
  110. (call-with-current-continuation
  111. (lambda (escape) escape))) (interaction-environment)))))
  112.  
  113. (define-syntax assert
  114. (syntax-rules ()
  115. ((_ x)
  116. (if (not x)
  117. (exit x)))))
  118.  
  119. (use-assertions)
  120.  
  121. (define (letters x res)
  122. (if (and (not (null? x)) (char-alphabetic? (car x)))
  123. (letters (cdr x) (string-append res (list->string (cons (car x) '()))))
  124. (list x res)))
  125.  
  126. (define (tokenize str)
  127. (define (tokens x res)
  128. (if (null? x)
  129. (reverse res)
  130. (let ((cur (car x)))
  131. (if (char-numeric? cur)
  132. (tokens (cdr x) (cons (- (char->integer cur) 48) res))
  133. (if (char-alphabetic? cur)
  134. (let ((s (letters x "")))
  135. (tokens (car s) (cons (string->symbol (cadr s)) res)))
  136. (if (equal? cur #\space)
  137. (tokens (cdr x) res)
  138. (if (or (equal? cur #\() (equal? cur #\)))
  139. (tokens (cdr x) (cons (list->string (cons cur '())) res))
  140. (if (or (equal? cur #\-) (equal? cur #\+) (equal? cur #\*) (equal? cur #\/) (equal? cur #\^))
  141. (tokens (cdr x) (cons (string->symbol (list->string (cons cur '()))) res))
  142. #f))))))))
  143. (tokens (string->list str) '()))
  144.  
  145. (define (sec a b)
  146. (if (not (null? b))
  147. (cons a b)
  148. a))
  149.  
  150. (define (power lst)
  151. (if (list? (peek lst))
  152. (expr lst)
  153. (list (next lst))))
  154.  
  155. (define (factors lst now)
  156. (if (equal? '^ (peek lst))
  157. (cons (next lst) (list (sec (let ((nowt (power lst))) (if (= (length nowt) 1) (car nowt) nowt)) (factors lst now))))
  158. (let ((cur (peek lst)))
  159. (if (or (equal? cur '+) (equal? cur '-) (equal? cur '*) (equal? cur '/) (equal? cur '^) (equal? cur ")") (equal? cur 'hell))
  160. now
  161. (assert #f)))))
  162.  
  163. (define (factor lst)
  164. (if (equal? 'hell (peek lst))
  165. (assert #f)
  166. (factors lst (power lst))))
  167.  
  168. (define (terms lst now)
  169. (if (or (equal? '* (peek lst)) (equal? '/ (peek lst)))
  170. (terms lst (list (if (= (length now) 1) (car now) now) (next lst) (let ((nowt (factor lst))) (if (= (length nowt) 1) (car nowt) nowt))))
  171. (let ((cur (peek lst)))
  172. (if (or (equal? cur '+) (equal? cur '-) (equal? cur '*) (equal? cur '/) (equal? cur '^) (equal? cur ")") (equal? cur 'hell))
  173. now
  174. (assert #f)))))
  175.  
  176. (define (term lst)
  177. (if (equal? 'hell (peek lst))
  178. (assert #f)
  179. (terms lst (factor lst))))
  180.  
  181. (define (exprs lst now)
  182. (if (or (equal? '+ (peek lst)) (equal? '- (peek lst)))
  183. (exprs lst (list (if (= (length now) 1) (car now) now) (next lst) (let ((nowt (term lst))) (if (= (length nowt) 1) (car nowt) nowt))))
  184. (let ((cur (peek lst)))
  185. (if (or (equal? cur '+) (equal? cur '-) (equal? cur '*) (equal? cur '/) (equal? cur '^) (equal? cur ")") (equal? cur 'hell))
  186. now
  187. (assert #f)))))
  188.  
  189. (define (expr lst)
  190. (if (equal? 'hell (peek lst))
  191. (assert #f)
  192. (exprs lst (term lst))))
  193.  
  194. (define (parse list)
  195. (define xex (make-source list 'hell))
  196. (expr xex))
  197.  
  198. (parse (tokenize "a^b^c^d"))
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement