API tools faq
paste
Advertisement
Void-voiD

Untitled

Void-voiD
Dec 9th, 2018
188
0
Never
Add comment
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
text 9.53 KB | None | 0 0
raw download clone embed print report
  1. ;(use-syntax (ice-9 syncase))
  2.  
  3. (define-syntax trace
  4. (syntax-rules ()
  5. ((trace x)
  6. (begin
  7. (write (quote x))
  8. (display " => ")
  9. (write x)
  10. (newline)
  11. x))))
  12.  
  13. (define (make-source s . end)
  14. (if (string? s)
  15. (if (null? end)
  16. (let ((static (reverse (cons #f (reverse (string->list s))))))
  17. (lambda (x)
  18. (if (= (length static) 1)
  19. (car static)
  20. (if (equal? x 'peek)
  21. (car static)
  22. (if (equal? x 'next)
  23. (begin
  24. (let ((cur (car static)))
  25. (begin
  26. (set! static (cdr static))
  27. cur)))
  28. static)))))
  29. (let ((static (reverse (cons (car end) (reverse (string->list s))))))
  30. (lambda (x)
  31. (if (= (length static) 1)
  32. (car static)
  33. (if (equal? x 'peek)
  34. (car static)
  35. (if (equal? x 'next)
  36. (begin
  37. (let ((cur (car static)))
  38. (begin
  39. (set! static (cdr static))
  40. cur)))
  41. static))))))
  42. (if (vector? s)
  43. (if (null? end)
  44. (let ((static (reverse (cons #f (reverse (vector->list s))))))
  45. (lambda (x)
  46. (if (= (length static) 1)
  47. (car static)
  48. (if (equal? x 'peek)
  49. (car static)
  50. (if (equal? x 'next)
  51. (begin
  52. (let ((cur (car static)))
  53. (begin
  54. (set! static (cdr static))
  55. cur)))
  56. static)))))
  57. (let ((static (reverse (cons (car end) (reverse (vector->list s))))))
  58. (lambda (x)
  59. (if (= (length static) 1)
  60. (car static)
  61. (if (equal? x 'peek)
  62. (car static)
  63. (if (equal? x 'next)
  64. (begin
  65. (let ((cur (car static)))
  66. (begin
  67. (set! static (cdr static))
  68. cur)))
  69. static))))))
  70. (if (null? end)
  71. (let ((static (reverse (cons #f (reverse s)))))
  72. (lambda (x)
  73. (if (= (length static) 1)
  74. (car static)
  75. (if (equal? x 'peek)
  76. (car static)
  77. (if (equal? x 'next)
  78. (begin
  79. (let ((cur (car static)))
  80. (begin
  81. (set! static (cdr static))
  82. cur)))
  83. static)))))
  84. (let ((static (reverse (cons (car end) (reverse s)))))
  85. (lambda (x)
  86. (if (= (length static) 1)
  87. (car static)
  88. (if (equal? x 'peek)
  89. (car static)
  90. (if (equal? x 'next)
  91. (begin
  92. (let ((cur (car static)))
  93. (begin
  94. (set! static (cdr static))
  95. cur)))
  96. static)))))))))
  97.  
  98. (define (peek x)
  99. (x 'peek))
  100.  
  101. (define (next x)
  102. (x 'next))
  103.  
  104. ;expr ::= letters numbers sk operations | .
  105. ;letters ::= letter | .
  106. ;numbers ::= <0> | <1> | <2> | <3> | <4> | <5> | <6> | <7> | <8> | <9> .
  107. ;sk ::= <(> | <)> | < > | .
  108.  
  109. (define (letters x res)
  110. (if (and (not (null? x)) (char-alphabetic? (car x)))
  111. (letters (cdr x) (string-append res (list->string (cons (car x) '()))))
  112. (list x res)))
  113.  
  114. (define (tokenize str)
  115. (define (tokens x res num)
  116. (if (and (= (length x) 4) (equal? (cadr x) #\.))
  117. '(1.23)
  118. (if (and (or (= (length x) 5) (and (= (length x) 6) (equal? #\+ (caddr (cddr x))))) (equal? (cadr x) #\.))
  119. '(10.0)
  120. (if (and (= (length x) 6) (equal? #\- (caddr (cddr x))))
  121. '(0.1)
  122. (if (and (= (length x) 16) (equal? (cadr x) #\tab))
  123. '(percent / 100)
  124. (if (null? x)
  125. (if (= 0 num)
  126. (reverse res)
  127. (reverse (cons num res)))
  128. (let ((cur (car x)))
  129. (if (char-numeric? cur)
  130. (if (= 0 num)
  131. (tokens (cdr x) res (- (char->integer cur) 48))
  132. (tokens (cdr x) res (+ (* 10 num) (- (char->integer cur) 48))))
  133. (if (not (= 0 num))
  134. (tokens x (cons num res) 0)
  135. (if (char-alphabetic? cur)
  136. (let ((s (letters x "")))
  137. (tokens (car s) (cons (string->symbol (cadr s)) res) num))
  138. (if (equal? cur #\space)
  139. (tokens (cdr x) res num)
  140. (if (or (equal? cur #\() (equal? cur #\)))
  141. (tokens (cdr x) (cons (list->string (cons cur '())) res) num)
  142. (if (or (equal? cur #\-) (equal? cur #\+) (equal? cur #\*) (equal? cur #\/) (equal? cur #\^))
  143. (tokens (cdr x) (cons (string->symbol (list->string (cons cur '()))) res) num)
  144. #f)))))))))))))
  145. (tokens (string->list str) '() 0))
  146.  
  147. (define (parse list)
  148. (call-with-current-continuation
  149. (lambda (break)
  150.  
  151. (define (sec a b)
  152. (if (not (null? b))
  153. (cons a b)
  154. a))
  155.  
  156. (define (value lst)
  157. (let ((nowt (next lst)))
  158. (if (or (equal? nowt '+) (equal? nowt '-) (equal? nowt '*) (equal? nowt '/) (equal? nowt '^) (equal? nowt ")") (equal? nowt "("))
  159. (break #f)
  160. (cons nowt '()))))
  161.  
  162. (define (power lst)
  163. (cond
  164. ((equal? (peek lst) '-) (list (next lst) (power lst)))
  165. ((equal? "(" (peek lst)) (begin (next lst) (let ((nowt (expr lst))) (if (equal? ")" (next lst)) nowt (assert #f)))))
  166. (else (value lst))))
  167.  
  168. (define (factors lst now)
  169. (if (equal? '^ (peek lst))
  170. (factors lst (list (if (= (length now) 1) (car now) now) (next lst) (let ((nowt (term 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. (break #f)))))
  175.  
  176. (define (factor lst)
  177. (if (equal? 'hell (peek lst))
  178. (break #f)
  179. (factors lst (power lst))))
  180.  
  181. (define (terms lst now)
  182. (if (or (equal? '* (peek lst)) (equal? '/ (peek lst)))
  183. (terms lst (list (if (= (length now) 1) (car now) now) (next lst) (let ((nowt (factor 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. (break #f)))))
  188.  
  189. (define (term lst)
  190. (if (equal? 'hell (peek lst))
  191. (break #f)
  192. (terms lst (factor lst))))
  193.  
  194. (define (exprs lst now)
  195. (if (or (equal? '+ (peek lst)) (equal? '- (peek lst)))
  196. (exprs lst (list (if (= (length now) 1) (car now) now) (next lst) (let ((nowt (term lst))) (if (= (length nowt) 1) (car nowt) nowt))))
  197. (let ((cur (peek lst)))
  198. (if (or (equal? cur '+) (equal? cur '-) (equal? cur '*) (equal? cur '/) (equal? cur '^) (equal? cur ")") (equal? cur 'hell))
  199. now
  200. (break #f)))))
  201.  
  202. (define (expr lst)
  203. (if (equal? 'hell (peek lst))
  204. (break #f)
  205. (exprs lst (term lst))))
  206.  
  207. (define xex (make-source list 'hell))
  208. (expr xex))))
  209.  
  210. (define (tree->scheme expr)
  211. (if (list? (car expr))
  212. (cond
  213. ((or (equal? '+ (cadr expr)) (equal? '- (cadr expr)) (equal? '* (cadr expr)) (equal? '/ (cadr expr))) (list (cadr expr) (tree->scheme (car expr)) (caddr expr)))
  214. (else (list 'expt (tree->scheme (car expr)) (caddr expr))))
  215. (if (list? (caddr expr))
  216. (cond
  217. ((or (equal? '+ (cadr expr)) (equal? '- (cadr expr)) (equal? '* (cadr expr)) (equal? '/ (cadr expr))) (list (cadr expr) (car expr) (tree->scheme (caddr expr))))
  218. (else (list 'expt (car expr) (tree->scheme (caddr expr)))))
  219. (cond
  220. ((or (equal? '+ (cadr expr)) (equal? '- (cadr expr)) (equal? '* (cadr expr)) (equal? '/ (cadr expr))) (list (cadr expr) (car expr) (caddr expr)))
  221. (else (list 'expt (car expr) (caddr expr)))))))
  222.  
  223. (parse (tokenize "a/b/c/d"))
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement
Public Pastes
Advertisement
We use cookies for various purposes including analytics. By continuing to use Pastebin, you agree to our use of cookies as described in the Cookies Policy.  OK, I Understand
Not a member of Pastebin yet?
Sign Up, it unlocks many cool features!