stau.space
Image Unit Processing Interface.
INFO: This is a mirror from GitHub.
github.com/sona-tau/iupi
Can parse some simple things now
+211
-46
+2
TODO.md
+2
TODO.md
···
38
38
- [ ] `(R, G, B)#{expr}` Executes `EXPR` as long as current pixel is of `(R, G, B)` color (while loop)
39
39
- [ ] `(R, G, B)${EXPR}` Run `EXPR` through every pixel in sequence until current pixel is of `(R, G, B)` color (for loop)
40
40
41
+
- [ ] Modularize the utilities and parser implementations in `main.rkt`
42
+
- [ ] Clean up the code with `(do)` statements
41
43
+209
-46
src/main.rkt
+209
-46
src/main.rkt
···
1
1
#lang plait
2
-
;; Useful utilities
2
+
;; Functional utilities
3
3
(define (id x) x)
4
+
4
5
(define (const a)
5
-
(lambda (b) a))
6
+
(λ (b) a))
7
+
8
+
(define (flip a)
9
+
(λ (x y) (a y x)))
6
10
11
+
(define (iota n)
12
+
(build-list n id))
13
+
14
+
(define (char->string [ch : Char]) : String
15
+
(list->string (list ch)))
16
+
17
+
(define (do [p : (ParseResult 'a)] [f : ((String * 'a) -> (ParseResult 'b))]) : (ParseResult 'b)
18
+
(type-case (ParseResult 'a) p
19
+
[(ok res) (f res)]
20
+
[(err) (err)]))
21
+
22
+
(define (p-result [left : String] [right : 'a]) : (ParseResult 'a)
23
+
(ok (pair left right)))
24
+
25
+
;; Constructs a pair 1 argument at a time
26
+
(define (pair-curried [x : 'a]) : ('b -> ('a * 'b))
27
+
(λ (y)
28
+
(pair x y)))
29
+
30
+
;; Zips two lists (its length is the length of the smaller list)
31
+
(define (zip [l1 : (Listof 'a)] [l2 : (Listof 'b)]) : (Listof ('a * 'b))
32
+
(if (or (empty? l1) (empty? l2))
33
+
'()
34
+
(cons (pair (first l1) (first l2)) (zip (rest l1) (rest l2)))))
35
+
36
+
;; Applies the leftside of a pair to the rightside
37
+
(define (apply-pair [p : (('a -> 'b) * 'a)]) : 'b
38
+
((fst p) (snd p)))
39
+
40
+
;; Maps apply-pair to a list
41
+
(define (apply-pair-list [lst : (Listof (('a -> 'b) * 'a))]) : (Listof 'b)
42
+
(map (λ (p) (apply-pair p)) lst))
43
+
44
+
;; Gets the first Char from a String
7
45
(define (first-char [s : String]) : (Optionof Char)
8
46
(if (empty? (string->list s))
9
47
[none]
10
48
[some (first (string->list s))]))
11
49
12
-
(define (string-tail [s : String])
50
+
;; Returns the tail of a String
51
+
(define (string-tail [s : String]) : String
13
52
(if (empty? (string->list s))
14
53
""
15
54
[list->string (rest (string->list s))]))
16
55
56
+
(define (char->num [c : Char]) : Number
57
+
(cond [(char=? c #\1) 1]
58
+
[(char=? c #\2) 2]
59
+
[(char=? c #\3) 3]
60
+
[(char=? c #\4) 4]
61
+
[(char=? c #\5) 5]
62
+
[(char=? c #\6) 6]
63
+
[(char=? c #\7) 7]
64
+
[(char=? c #\8) 8]
65
+
[(char=? c #\9) 9]
66
+
[(char=? c #\0) 0]
67
+
))
68
+
69
+
;; Parser Stuff
70
+
;; Parse result type
17
71
(define-type (ParseResult 'a)
18
-
[success (r : (Optionof (String * 'a)))]
19
-
[failure])
72
+
[ok (r : (String * 'a))]
73
+
[err])
74
+
75
+
;; Parser type
76
+
(define-type-alias (Parser 'a) (String -> (ParseResult 'a)))
20
77
21
78
;; Language implementation
79
+
;; Language types
22
80
(define-type U8
23
81
[num (n : Number)])
24
82
···
31
89
[setter (c : Color)])
32
90
33
91
(define-type Color
34
-
[hex-color (n : Number)] ;; TODO: Hex should turn a string of #FFA123 into a Number
35
-
[int-color (n : Number)])
92
+
; [hex-color (n : Number)] ;; TODO: Hex should turn a string of #FFA123 into a Number
93
+
; [rgb-color (n : (Number * Number * Number))]
94
+
[grayscale-color (n : Number)])
95
+
96
+
(define (color-add [c1 : Color] [c2 : Color]) : Color
97
+
(type-case Color c1
98
+
; [(hex-color n) ]
99
+
; [(rgb-color nnn) ]
100
+
[(grayscale-color n) (type-case Color c2
101
+
[(grayscale-color m) (grayscale-color (+ n m))])]))
36
102
37
103
(define-type NumOps
38
104
[addR (n : Number)]
···
40
106
41
107
(define-type Expr
42
108
[img-op (op : ImgOps)]
43
-
[num-op (op : NumOps)]
44
-
)
45
-
46
-
;; Original s-expr parser implementation
47
-
;(define (parse e)
48
-
; [cond
49
-
; [(s-exp-match? `& e) (rotate-left)]
50
-
; [(s-exp-match? `(NUMBER) e) (setter (int-color (get-SetNum e)))]
51
-
; [(s-exp-match? `<> e) (mirror)]
52
-
; [else (rotate-left)]
53
-
; ]
54
-
;)
109
+
[num-op (op : NumOps)])
55
110
56
-
(define (char/p [c : Char])
57
-
(lambda (s)
111
+
;; char/p implementation
112
+
(define (char/p [c : Char]) : (Parser Char)
113
+
(λ (s)
58
114
(type-case (Optionof Char) (first-char s)
59
-
[(some x) (if (char=? x c) (some (pair (string-tail s) c)) (none))]
60
-
[(none) (none)])))
61
-
62
-
(define (parse-string p s)
63
-
(p s))
115
+
[(some x) (if (char=? x c) (ok (pair (string-tail s) c)) (err))]
116
+
[(none) (err)])))
64
117
118
+
(define (run-parser [p : (Parser 'a)] [s : String]) (p s))
65
119
66
120
;; The following functor and applicative implementations for char/p were taken
67
121
;; from the prelude implementation of haskell at:
68
122
;; https://hackage.haskell.org/package/base-4.19.1.0/docs/src/GHC.Base.html
69
123
70
124
;; char/p functor
71
-
(define (fmap f p)
72
-
(lambda (input)
73
-
(type-case (Optionof (String * 'a)) (p input)
74
-
[(some x) (some (pair (fst x) (f (snd x))))]
75
-
[(none) (none)])))
125
+
(define (fmap [f : ('a -> 'b)] [p : (Parser 'a)]) : (Parser 'b)
126
+
(λ (input)
127
+
(do (p input)
128
+
(λ (x) (ok (pair (fst x) (f (snd x))))))))
76
129
77
130
;; char/p applicative
78
-
(define (pure x) : (String -> (Optionof (String * 'a)))
79
-
(lambda (input)
80
-
(some (pair input x))))
131
+
(define (pure [x : 'a]) : (Parser 'a)
132
+
(λ (input)
133
+
(ok (pair input x))))
134
+
135
+
(define (seq-ap [p1 : (Parser ('a -> 'b))] [p2 : (Parser 'a)]) : (Parser 'b)
136
+
(λ (input)
137
+
(type-case (ParseResult ('a -> 'b)) (p1 input)
138
+
[(ok f) (do (p2 input)
139
+
(λ (y) (p-result (fst y) ((snd f) (snd y)))))]
140
+
[(err) (err)])))
141
+
142
+
(define (m-join [p1 : (Parser Char)] [p2 : (Parser Char)]) : (Parser String)
143
+
(λ (input)
144
+
(type-case (ParseResult Char) (p1 input)
145
+
[(ok r1) ;(do (p2 (fst r1))
146
+
; (λ (r2) (p-result (fst r2) (list->string (list (snd r1) (snd r2))))))]
147
+
148
+
(type-case (ParseResult Char) (p2 (fst r1))
149
+
[(ok r2) (ok (pair (fst r2) (list->string (list (snd r1) (snd r2)))))]
150
+
[(err) (err)])]
151
+
[(err) (err)])))
152
+
153
+
;; char/p monoid
154
+
(define (m-append [p1 : (Parser Char)] [p2 : (Parser String)]) : (Parser String)
155
+
(λ (input)
156
+
(type-case (ParseResult Char) (p1 input)
157
+
[(ok r1) (type-case (ParseResult String) (p2 (fst r1))
158
+
[(ok r2) (ok (pair (fst r2) (string-append (snd r2) (list->string (list (snd r1))))))]
159
+
[(err) (err)])]
160
+
[(err) (err)])))
161
+
162
+
(define (m-prepend [p1 : (Parser String)] [p2 : (Parser Char)]) : (Parser String)
163
+
(λ (input)
164
+
(type-case (ParseResult String) (p1 input)
165
+
[(ok r1) (type-case (ParseResult Char) (p2 (fst r1))
166
+
[(ok r2) (ok (pair (fst r2) (string-append (snd r1) (list->string (list (snd r2))))))]
167
+
[(err) (err)])]
168
+
[(err) (err)])))
169
+
170
+
;; string/p implementation
171
+
(define (string/p [s : String]) : (Parser String)
172
+
(foldr (flip m-prepend) (pure "") (reverse (map char/p (string->list s)))))
173
+
174
+
;; parsers
175
+
(define (p-transpose [s : String]) : (ParseResult 'a)
176
+
(type-case (ParseResult String) ((string/p "&") s)
177
+
[(ok result) (ok (pair (fst result) (list transpose)))]
178
+
[(err) (err)]))
179
+
180
+
(define (alt [res1 : (ParseResult 'a)] [res2 : (ParseResult 'a)]) : (ParseResult 'a)
181
+
(type-case (ParseResult 'a) res1
182
+
[(ok x) (ok x)]
183
+
[(err) res2]))
184
+
185
+
(define (p-or [ps : (Listof (Parser 'a))]) : (Parser 'a)
186
+
(λ (input)
187
+
(let ([res1 ((first ps) input)])
188
+
(foldr alt res1 (map (λ (p) (p input)) (rest ps))))))
189
+
190
+
(define (p-append [r1 : (ParseResult Char)] [r2 : (ParseResult String)]) : (ParseResult String)
191
+
(type-case (ParseResult Char) r1
192
+
[(ok p1) (type-case (ParseResult String) r2
193
+
[(ok p2) (if (string=? (fst p1) (fst p2))
194
+
(ok (pair (fst p1) (string-append (char->string (snd p1)) (snd p2))))
195
+
(err))]
196
+
[(err) (err)])]
197
+
[(err) (err)]))
198
+
199
+
(define (p-alt [p1 : (Parser 'a)] [p2 : (Parser 'a)]) : (Parser 'a)
200
+
(λ (input) (alt (p1 input) (p2 input))))
201
+
202
+
(define (p-many [p : (Parser 'a)]) : (Parser (Listof 'a))
203
+
(p-alt (p-many1 p) (pure '())))
204
+
205
+
(define (p-many1 [p : (Parser 'a)]) : (Parser (Listof 'a))
206
+
(λ (input) (type-case (ParseResult 'a) (p input)
207
+
[(ok first) (type-case (ParseResult (Listof 'a)) ((p-many p) (fst first))
208
+
[(ok rest) (ok (pair (fst rest) (append (list (snd first)) (snd rest))))]
209
+
[(err) (err)])]
210
+
[(err) (err)])))
211
+
212
+
; sergio was here >:) (it took me 3 hours to type this in dvorak)
81
213
82
-
(define (seq [p1 : (String -> (Optionof (String * ('a -> 'b))))] [p2 : (String -> (Optionof (String * 'a)))])
83
-
(lambda (input)
84
-
(type-case (Optionof (String * ('a -> 'b))) (p1 input)
85
-
[(some x) (type-case (Optionof (String * 'a)) (p2 input)
86
-
[(some y) (some (pair (fst y) ((snd x) (snd y))))]
87
-
[(none) (none)])]
88
-
[(none) (none)])))
214
+
(define (p-digit [s : String]) : (ParseResult 'a)
215
+
((p-or (list (char/p #\1)
216
+
(char/p #\2)
217
+
(char/p #\3)
218
+
(char/p #\4)
219
+
(char/p #\5)
220
+
(char/p #\6)
221
+
(char/p #\7)
222
+
(char/p #\8)
223
+
(char/p #\9)
224
+
(char/p #\0))) s))
225
+
226
+
(define (left-p [l : (Parser 'a)] [r : (Parser 'b)]); : (Parser 'a)
227
+
(λ (input) (do (l input)
228
+
(λ (result1) (do (r (fst result1))
229
+
(λ (result2) (p-result (fst result2) (snd result1))))))))
230
+
231
+
(define (right-p [l : (Parser 'a)] [r : (Parser 'b)]) : (Parser 'b)
232
+
(λ (input) (do (l input)
233
+
(λ (result1) (do (r (fst result1))
234
+
(λ (result2) (ok result2)))))))
235
+
236
+
(define (p-number [s : String]) : (ParseResult Number)
237
+
(do ((p-many1 p-digit) s)
238
+
(λ (char-list)
239
+
(p-result (fst char-list)
240
+
(foldl (λ (acc x) (+ (* 10 x) acc)) 0 (map char->num (snd char-list)))))))
89
241
90
-
;; TODO: figure out what the type check error means.
91
-
;(define (sequenceA [lst : (Listof (String -> (Optionof (String * 'a))))])
92
-
; (if (empty? lst) (pure (list)) (seq (fmap cons (first lst)) (sequenceA (rest lst)))))
93
-
242
+
(define (p-color [s : String]) : (ParseResult Color)
243
+
(do ((left-p (right-p (char/p #\() p-number) (char/p #\))) s)
244
+
(λ (result) (p-result (fst result) (grayscale-color (snd result))))))
94
245
246
+
(define (p-add [s : String]) : (ParseResult Color)
247
+
(do (p-color s)
248
+
(λ (col1) (do ((right-p (char/p #\+) p-color) (fst col1))
249
+
(λ (col2) (p-result (fst col2) (color-add (snd col1) (snd col2))))))))
250
+
95
251
;; some tests
252
+
((fmap (const #\a) (char/p #\n)) "nice")
96
253
(map char/p (string->list "null"))
97
-
((fmap (const #\a) (char/p #\n)) "nice")
254
+
((m-join (char/p #\a) (char/p #\p)) "apple")
255
+
((m-prepend (m-join (char/p #\a) (char/p #\p)) (char/p #\p)) "apple")
256
+
257
+
258
+
(p-number "123")
259
+
(p-color "(123)")
260
+
(p-add "(123)+(579)")