-
Notifications
You must be signed in to change notification settings - Fork 0
/
001.scm
122 lines (111 loc) · 2.54 KB
/
001.scm
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
;; Exercice 1 of programming praxis
;; http://programmingpraxis.com/2009/02/19/rpn-calculator/
;; TODO comply to the one line rule
;; no srfi-1 avail (function useless in here)
(define fold
(lambda (f init l)
(cond
((null? l) init)
(else (f (car l) (fold f init (cdr l))))
)
)
)
;; s -> boolean
(define exit?
(lambda (s)
(and (string? s) (eq? (string->symbol s) 'exit))
)
)
(define-structure
operand
;; char
name
;; function
action
)
;; assume that we act on numbers
(define *operands*
`(
,(make-operand "+" (lambda (a b) (+ a b)))
,(make-operand "-" (lambda (a b) (- a b)))
,(make-operand "*" (lambda (a b) (* a b)))
;; TODO check for div by 0
,(make-operand "/" (lambda (a b) (/ a b)))
)
)
;; -> operand or #f
(define get-operand
(lambda (what search-in f)
(cond
((null? search-in) #f)
((equal? (f (car search-in)) what) (car search-in))
(else (get-operand what (cdr search-in) f))
)
)
)
;; small helper
;; string -> operand or #f
(define get-operand-by-name
(lambda (name)
(get-operand name *operands* (lambda (operand) (operand-name operand)))
)
)
;; string -> boolean
(define operand?
(lambda (s)
(and (string? s) (get-operand-by-name s))
)
)
(define dispatch-operand
(lambda (operand rest)
(if (or (not (operand? operand)) (not (eq? 2 (length rest))))
(error "Invalid operand name")
(apply (operand-action (get-operand-by-name operand)) rest)
)
)
)
(define rpn
(lambda ()
(define empty-stack '())
(define push
(lambda (item stack)
(cons item stack)
)
)
(define next-token
(lambda ()
(read)
)
)
(let loop (
[stack empty-stack]
[token (next-token)]
)
(cond
;; number
(
(number? token)
(loop (push token stack) (next-token))
)
;; operand
(
(operand? (symbol->string token))
(if (>= (length stack) 2)
(let ([result (dispatch-operand (symbol->string token) (list (cadr stack) (car stack)))])
(println "result: " result)
(loop (push result (cddr stack)) (next-token))
)
(error "An operand should only be run against a stack of 2 numbers")
)
)
;; exit?
(
(exit? (symbol->string token))
(println "bye")
)
;; catch all
(else (error "Invalid (unrecognized token)"))
)
)
)
)