stau.space
Image Unit Processing Interface.
INFO: This is a mirror from GitHub.
github.com/sona-tau/iupi
1#lang plait
2
3(require "utilities.rkt")
4(require "parser.rkt")
5(require "types.rkt")
6(require "combinators.rkt")
7
8;----- Language Implementation -----;
9; Converts a single digit into a number. Basically just returns the number
10; contained inside the digit.
11(define (digit->number [d : Digit]) : Number
12 (type-case Digit d
13 [(digit n) n]))
14
15; Converts a series of digits into a number.
16(define (digits->number [ds : Digits]) : Number
17 (type-case Digits ds
18 [(number first rest) (+ (digit->number first) (* 10 (digits->number rest)))]
19 [(empty-digit) 0]))
20
21; Converts a decimal into a number.
22(define (decimals->number [dc : Decimals]) : Number
23 (type-case Decimals dc
24 [(decimals first rest) (/ (+ (digit->number first) (decimals->number rest)) 10)]
25 [(empty-decimal) 0]))
26
27; Converts a floating point type number into a number.
28(define (float->number [fp : Float]) : Number
29 (type-case Float fp
30 [(float ds) (decimals->number ds)]))
31
32;----- Language Functionality -----;
33; Helper function to create binary operations.
34(define (bin-op-builder [c1 : RGBColor] [c2 : RGBColor] [f : (Number Number -> Number)]) : RGBColor
35 (type-case RGBColor c1
36 [(rgbcolor red1 green1 blue1) (type-case RGBColor c2
37 [(rgbcolor red2 green2 blue2) (let*
38 [(r1 (digits->number red1))
39 (r2 (digits->number red2))
40 (g1 (digits->number green1))
41 (g2 (digits->number green2))
42 (b1 (digits->number blue1))
43 (b2 (digits->number blue2))
44 (r3 (mod256 (f r1 r2)))
45 (g3 (mod256 (f g1 g2)))
46 (b3 (mod256 (f b1 b2)))]
47 (rgbcolor (number->digits r3) (number->digits g3) (number->digits b3)))])]))
48
49; Add two colors
50(define (color-add [c1 : RGBColor] [c2 : RGBColor]) : RGBColor
51 (bin-op-builder c1 c2 +))
52
53; Multiply two colors
54(define (color-multiply [c1 : RGBColor] [c2 : RGBColor]) : RGBColor
55 (bin-op-builder c1 c2 (λ (n m) (floor (* n m)))))
56
57; Divide two colors (will floor their values and return 0 if divide by 0)
58(define (color-divide [c1 : RGBColor] [c2 : RGBColor]) : RGBColor
59 (bin-op-builder c1 c2 (λ (n m) (if (= m 0) 0 (floor (/ n m))))))
60
61; Subtract two colors
62(define (color-subtract [c1 : RGBColor] [c2 : RGBColor]) : RGBColor
63 (bin-op-builder c1 c2 -))
64
65; Invert the luminosity of a color
66(define (color-value-invert [c1 : RGBColor]) : RGBColor
67 (type-case HSVColor (rgb->hsv c1)
68 [(hsvcolor h1 s1 v1)
69 (let [(h2 h1) (s2 s1) (v2 (- 1 v1))] (hsv->rgb [hsvcolor h2 s2 v2]))]))
70
71; Invert each RGB value of a color
72(define (color-linear-invert [c : RGBColor]) : RGBColor
73 (color-subtract [rgbcolor (number->digits 255) (number->digits 255) (number->digits 255)] c))
74
75; Interpolate a color between two other colors
76(define (color-interpolate [c1 : RGBColor] [c2 : RGBColor] [percent : Float]) : RGBColor
77 (type-case HSVColor (rgb->hsv c1)
78 [(hsvcolor h1 s1 v1) (type-case HSVColor (rgb->hsv c2)
79 [(hsvcolor h2 s2 v2)
80 (let* [(prcnt (float->number percent))
81 (h3 (interpolate-num h1 h2 prcnt))
82 (s3 (interpolate-num s1 s2 prcnt))
83 (v3 (interpolate-num v1 v2 prcnt))] (hsv->rgb (hsvcolor h3 s3 v3)))])]))
84
85; Sums all rgb values of a color
86(define (sumar-color [color : RGBColor] ) : Number
87 (+
88 (+
89 (mod256(digits->number(rgbcolor-red color)))
90 (mod256(digits->number(rgbcolor-blue color))))
91 (mod256(digits->number(rgbcolor-green color)))))
92
93; Choose the color with larger values
94(define (color-max [c1 : RGBColor] [c2 : RGBColor]) : RGBColor
95 (let ((sumc1 (sumar-color c1))
96 (sumc2 (sumar-color c2)))
97 (cond ((> sumc1 sumc2) c1)
98 (else c2))))
99
100; Choose the color with smaller values
101(define (color-min [c1 : RGBColor] [c2 : RGBColor]) : RGBColor
102 (let ((sumc1 (sumar-color c1))
103 (sumc2 (sumar-color c2)))
104 (cond ((< sumc1 sumc2) c1)
105 (else c2))))
106
107
108; Convert HSVColor to RGB
109(define (hsv->rgb [c : HSVColor]) : RGBColor
110 (type-case HSVColor c
111 [(hsvcolor hue saturation value) (let [(h hue) (s saturation) (v value)]
112 (let* [(chroma (* v s))
113 (hp (/ h 60))
114 (x (if (even? (round hp)) 0 chroma))
115 (c1 [cond
116 [(< hp 1) (list chroma x 0)]
117 [(< hp 2) (list x chroma 0)]
118 [(< hp 3) (list 0 chroma x)]
119 [(< hp 4) (list 0 x chroma)]
120 [(< hp 5) (list x 0 chroma)]
121 [else (list chroma 0 x)]])
122 (m (- v chroma))
123 (r (round (* 256 (+ (first c1) m))))
124 (g (round (* 256 (+ (second c1) m))))
125 (b (round (* 256 (+ (third c1) m))))] (rgbcolor (number->digits r) (number->digits g) (number->digits b))))]))
126
127; Convert RGB color to HSV color
128(define (rgb->hsv [c : RGBColor]) : HSVColor
129 (type-case RGBColor c
130 [(rgbcolor red green blue) (let*
131 [(r (/ (digits->number red) 255))
132 (g (/ (digits->number green) 255))
133 (b (/ (digits->number blue) 255))
134 (x+ (maxel (list r g b)))
135 (x- (minel (list r g b)))
136 (v x+)
137 (c (- x+ x-))
138 (l (/ (+ x+ x-) 2))
139 (h [cond
140 [(= c 0) 0]
141 [(= v r) (* 60 (modulo (round (/ (- g b) c)) 6))]
142 [(= v g) (* 60 (+ (/ (- b r) c) 2))]
143 [(= v b) (* 60 (+ (/ (- r g) c) 4))]
144 [else 0]])
145 (s (if (= v 0) 0 (/ c v)))
146 ] (hsvcolor h s v))]))
147
148;----- The Parsers -----;
149; Parser that parses a single digit.
150(define (p-digit [s : String]) : (ParseResult Digit)
151 (do ((or/p (list (char/p #\1)
152 (char/p #\2)
153 (char/p #\3)
154 (char/p #\4)
155 (char/p #\5)
156 (char/p #\6)
157 (char/p #\7)
158 (char/p #\8)
159 (char/p #\9)
160 (char/p #\0))) s)
161 (λ (result) (let [(char (snd result)) (cdr (fst result))] (return cdr (digit (char->num char)))))))
162
163; Parser that parses many digits. Will continue consuming digits from the input
164; string until the parser fails. In which case it will return the sequence of
165; digits that have been parsed already.
166(define (p-digits [s : String]) : (ParseResult Digits)
167 (do ((many1/p p-digit) s)
168 (λ (result) (let [(digitlist (snd result)) (cdr (fst result))] (return cdr (digitlist->digits digitlist))))))
169
170; Parser that parses decimal numbers.
171(define (p-decimals [s : String]) : (ParseResult Decimals)
172 (do ((many1/p p-digit) s)
173 (λ (result) (let [(digitlist (snd result)) (cdr (fst result))] (return cdr (digitlist->decimals digitlist))))))
174
175; Parser that parses an entire floating point number.
176(define (p-float [s : String]) : (ParseResult Float)
177 (do ((right/p (char/p #\.) p-decimals) s)
178 (λ (result) (let* [(decimals (snd result)) (cdr (fst result))] (return cdr (float decimals))))))
179
180; Parser that parses an entire color. Returns a (ParseResult RGBColor) where
181; each component of the RGBColor is of type Digits.
182(define (p-color [s : String]) : (ParseResult RGBColor)
183 (do ((right/p (char/p #\() p-digits) s)
184 (λ (result1) (let [(red (snd result1)) (cdr1 (fst result1))]
185 (do ((right/p (char/p #\,) p-digits) cdr1)
186 (λ (result2) (let [(green (snd result2)) (cdr2 (fst result2))]
187 (do ((left/p (right/p (char/p #\,) p-digits) (char/p #\))) cdr2)
188 (λ (result3) (let [(blue (snd result3)) (cdr3 (fst result3))]
189 (return cdr3 (rgbcolor red green blue))))))))))))
190
191; Parser that parses a unary operation. It will also parse the rest of the
192; source code and use it as an argument for the unary operation argument.
193(define (p-unary-operation [s : String]) : (ParseResult UnaryOperation)
194 (do ((or/p (list (seq/p (string/p "<^>") p-lang) (seq/p (string/p "<|>") p-lang))) s)
195 (λ (result) (let [(op-string (fst (snd result))) (lang (snd (snd result))) (cdr (fst result))]
196 (return cdr (if (string=? op-string "<^>")
197 (value-invert lang)
198 (linear-invert lang)))))))
199
200; Parser that parses an operator symbol and color. This is a helper function for
201; (p-binary-operation). This function is necessary because the symbol in the
202; middle can either be a symbol string or a floating-point number. Wrapping the
203; result in OperatorType means that the data gathered from this parse can then
204; be type-checked by plait correctly.
205(define (p-operator-type [s : String]) : (ParseResult OperatorType)
206 (type-case (ParseResult String) ((or/p (list
207 (string/p "+")
208 (string/p "-")
209 (string/p "*")
210 (string/p "/")
211 (string/p "^")
212 (string/p "!"))) s)
213 [(ok result) (let [(str (snd result)) (cdr (fst result))] (return cdr (string-type str)))]
214 [(err) (do (p-float s)
215 (λ (result) (let [(n (snd result)) (cdr (fst result))](return cdr (floating-type n)))))]))
216
217; Parser that parses a binary operation. The recursive nature of this parser
218; means that it will continue parsing the input string until it cannot continue.
219; In which case it starts evaluating the expression.
220(define (p-binary-operation [s : String]) : (ParseResult BinaryOperation)
221 (do ((seq/p p-color (seq/p p-operator-type p-expr)) s)
222 (λ (result) (let* [(col-type-expr (snd result)) (col (fst col-type-expr)) (op-type (fst (snd col-type-expr))) (expr (snd (snd col-type-expr))) (cdr (fst result))]
223 (return cdr (type-case OperatorType op-type
224 [(floating-type fp) (interpolate col expr fp)]
225 [(string-type str) [cond
226 [(string=? str "+") (add col expr)]
227 [(string=? str "-") (subtract col expr)]
228 [(string=? str "*") (multiply col expr)]
229 [(string=? str "/") (divide col expr)]
230 [(string=? str "^") (max col expr)]
231 [(string=? str "!") (min col expr)]]]))))))
232
233; Parser that parses an entire expression. This type is necessary to separate
234; the (UnaryOperation)'s from the (BinaryOperation)'s.
235(define (p-expr [s : String]) : (ParseResult Expr)
236 (type-case (ParseResult BinaryOperation) (p-binary-operation s)
237 [(ok result) (let [(bin-op (snd result)) (cdr (fst result))]
238 (return cdr (operation bin-op)))]
239 [(err) (type-case (ParseResult RGBColor) (p-color s)
240 [(ok result) (let [(col (snd result)) (cdr (fst result))]
241 (return cdr (color col)))]
242 [(err) (err)])]))
243
244; Parser that parses the entire language.
245(define (p-lang [s : String]) : (ParseResult Language)
246 (type-case (ParseResult UnaryOperation) (p-unary-operation s)
247 [(ok result) (let [(un-op (snd result)) (cdr (fst result))]
248 (return cdr (unary-operation un-op)))]
249 [(err) (type-case (ParseResult BinaryOperation) (p-binary-operation s)
250 [(ok result) (let [(bin-op (snd result)) (cdr (fst result))]
251 (return cdr (binary-operation bin-op)))]
252 [(err) (type-case (ParseResult RGBColor) (p-color s)
253 [(ok result) (let [(col (snd result)) (cdr (fst result))]
254 (return cdr (lang-color col)))]
255 [(err) (err)])])]))
256
257;----- Evaluation -----;
258; Evaluates a parsed language and returns the corresponding (RGBColor) that
259; would result if the expression was computed.
260(define (evaluate [src : Language]) : RGBColor
261 (type-case Language src
262 [(binary-operation op) (eval-binary-operation op)]
263 [(unary-operation op) (eval-unary-operation op)]
264 [(lang-color col) col]))
265
266; Evaluates a unary operation.
267(define (eval-unary-operation [op : UnaryOperation]) : RGBColor
268 (type-case UnaryOperation op
269 [(value-invert col) (color-value-invert (evaluate col))]
270 [(linear-invert col) (color-linear-invert (evaluate col))]))
271
272; Evaluates a binary operation.
273(define (eval-binary-operation [op : BinaryOperation]) : RGBColor
274 (type-case BinaryOperation op
275 [(add col exp) (color-add col (eval-expr exp))]
276 [(subtract col exp) (color-subtract col (eval-expr exp))]
277 [(multiply col exp) (color-multiply col (eval-expr exp))]
278 [(divide col exp) (color-divide col (eval-expr exp))]
279 [(interpolate col exp percent) (color-interpolate col (eval-expr exp) percent)]
280 [(max col exp) (color-max col (eval-expr exp))]
281 [(min col exp) (color-min col (eval-expr exp))]))
282
283; Evaluates an expression.
284(define (eval-expr [e : Expr]) : RGBColor
285 (type-case Expr e
286 [(operation op) (eval-binary-operation op)]
287 [(color col) col]))
288
289;----- Tests -----;
290(define accept1 "(0,000000,010)")
291(define accept2 "<|><^>(0,0,0)")
292(define accept3 "(0,0,0)/(0,0,0)")
293(define accept4 "(400,100,200)+(10,10,10)/(2,2,2)")
294(define accept5 "(0,0,00).32(0100,319,7880).0(400,100,200)")
295
296(define deny1 "(0,0,0.0)")
297(define deny2 "<|>(0,0,00)<^>(100,319,80)")
298(define deny3 "(0,0,00)0.32(0100,319,7880)")
299(define deny4 "(400,100,200)++(10,10,10)")
300(define deny5 "(400,100,200)+")
301
302; Testing function for strings.
303(define (tester [s : String]) : RGBColor
304 (type-case (ParseResult Language) (p-lang s)
305 [(ok lang) (cond
306 [(not (string=? "" (fst lang))) (error 'incompleteParse (fst lang))]
307 [else (evaluate (snd lang))])]
308 [(err) (error 'parseFailed "not a valid string")]))
309
310"Accept 1:"
311(tester accept1)
312"Accept 2:"
313(tester accept2)
314"Accept 3:"
315(tester accept3)
316"Accept 4:"
317(tester accept4)
318"Accept 5:"
319(tester accept5)
320
321;"Deny 1:"
322;(tester deny1)
323;"Deny 2:"
324;(tester deny2)
325;"Deny 3:"
326;(tester deny3)
327;"Deny 4:"
328;(tester deny4)
329;"Deny 5:"
330;(tester deny5)