/pliant/graphic/color/rgb888.pli
1	module "/pliant/language/compiler.pli"
2
3
4	public
5	type ColorRGB888
6	field uInt8 r g b
7
8
9	function rgb_color r g b -> p
10	arg Int r g b ; arg ColorRGB888 p
11	p r := r ; p g := g ; p b := b
12
13	function hsl_color h s l -> p
14	arg Float h s l ; arg ColorRGB888 p
15	check h>=0 and h<360
16	for (var Int i) 0 2
17	var Float hi := h-120*i
18	while hi<(-180)
19	hi += 360
20	while hi>=180
21	hi -= 360
22	var Float f := shunt hi<0 (1/60)*hi+2 -(1/60)*hi+2
23	f := shunt f<=0 0 f>=1 1 f
24	# f :=  f*s/100 + l/100*(1-s/100)
25	f :=  f*s/100 + 0.5*(1-s/100)
26	if l>50
27	f := f+(1-f)*0.02*(l-50)
28	else
29	f *= l/50
30	(addressof:p translate uInt8 i) map uInt8 := cast f*255 uInt
31
32	function unhexa s -> i
33	arg Str s ; arg Int i
34	i := 0
35	for (var Int j) 0 s:len-1
36	var Int c := s:j number
37	if c>="0":0:number and c<="9":0:number
38	i := i*16+(c-"0":0:number)
39	eif c>="A":0:number and c<="F":0:number
40	i := i*16+(c-"A":0:number+10)
41	eif c>="a":0:number and c<="f":0:number
42	i := i*16+(c-"a":0:number+10)
43	else
44	return undefined
45
46	function hexa_color s -> p
47	arg Str s ; arg ColorRGB888 p
48	p r := unhexa (s 0 2)
49	p g := unhexa (s 2 2)
50	p b := unhexa (s 4 2)
51
52	function html_color s -> p
53	arg Str s ; arg ColorRGB888 p
54	p r := unhexa (s 1 2)
55	p g := unhexa (s 3 2)
56	p b := unhexa (s 5 2)
57
58
59	meta color e
60	var Link:Argument c :> argument local ColorRGB888
61	if e:size=4 and e:0:ident="hsl" and (e:1 cast Float) and (e:2 cast Float) and (e:3 cast Float)
62	e suckup e:1 ; e suckup e:2 ; e suckup e:3
63	e add (instruction (the_function hsl_color Float Float Float -> ColorRGB888) e:1:result e:2:result e:3:result c)
64	eif e:size=4 and e:0:ident="rgb" and (e:1 cast Int) and (e:2 cast Int) and (e:3 cast Int)
65	e suckup e:1 ; e suckup e:2 ; e suckup e:3
66	e add (instruction (the_function rgb_color Int Int Int -> ColorRGB888) e:1:result e:2:result e:3:result c)
67	eif e:size=2 and e:0:ident="hexa" and (e:1 cast Str)
68	e suckup e:1
69	e add (instruction (the_function hexa_color Str -> ColorRGB888) e:1:result c)
70	eif e:size=2 and e:0:ident="html" and (e:1 cast Str)
71	e suckup e:1
72	e add (instruction (the_function html_color Str -> ColorRGB888) e:1:result c)
73	else
74	return
75	e set_result c access_read
76
77
78	function component255 i -> c
79	arg Int i ; arg Str c
80	check i>=0 and i<256
81	c := right (string i "radix 16") 2 "0"
82
83	method p 'to string' options -> s
84	arg ColorRGB888 p ; arg Str options s
85	s := (shunt options="html" "#" "")+(component255 p:r)+(component255 p:g)+(component255 p:b)
86
87	method p 'from string' string options may_skip skiped offset -> status
88	arg_w ColorRGB888 p ; arg Str string options ; arg CBool may_skip ; arg_w Int skiped offset ; arg Status status
89	var Link:Str str :> new Str
90	status := str 'from string' string options may_skip skiped offset
91	if status=success
92	if str:len=6
93	p := hexa_color str
94	eif str:len=7 and str:0="#"
95	p := html_color str
96	eif (str parse word:"color" word:"rgb" (var Int r) (var Int g) (var Int b))
97	p := rgb_color r g b
98	eif (str parse word:"color" word:"hsl" (var Float h) (var Float s) (var Float l))
99	p := hsl_color h s l
100	else
101	status := failure
102
103	function shade p l -> q
104	arg ColorRGB888 p ; arg Float l ; arg ColorRGB888 q
105	if l>0
106	q r := cast p:r+(255-p:r)*l Int
107	q g := cast p:g+(255-p:g)*l Int
108	q b := cast p:b+(255-p:b)*l Int
109	else
110	var Float m := 1+l
111	q r := cast p:r*m Int
112	q g := cast p:g*m Int
113	q b := cast p:b*m Int
114
115
116	export color shade
117
118
119
120
121
122
123