/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 b ; arg ColorRGB888 p 
 11    := r ; := g ; := b 
 12   
 13  function hsl_color h s l -> p 
 14    arg Float l ; arg ColorRGB888 p 
 15    check h>=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 := shunt hi<0 (1/60)*hi+-(1/60)*hi+2 
 23      := shunt f<=0 0 f>=1 1 f 
 24      # f :=  f*s/100 + l/100*(1-s/100) 
 25      :=  f*s/100 0.5*(1-s/100) 
 26      if l>50 
 27        := f+(1-f)*0.02*(l-50) 
 28      else 
 29        *= l/50 
 30      (addressof:translate uInt8 i) map uInt8 := cast f*255 uInt 
 31   
 32  function unhexa s -> i 
 33    arg Str s ; arg Int i 
 34    := 0 
 35    for (var Int j) s:len-1 
 36      var Int := s:number 
 37      if c>="0":0:number and c<="9":0:number 
 38        := i*16+(c-"0":0:number) 
 39      eif c>="A":0:number and c<="F":0:number 
 40        := i*16+(c-"A":0:number+10) 
 41      eif c>="a":0:number and c<="f":0:number 
 42        := 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    := unhexa (0 2) 
 49    := unhexa (2 2) 
 50    := unhexa (4 2) 
 51   
 52  function html_color s -> p 
 53    arg Str s ; arg ColorRGB888 p 
 54    := unhexa (1 2) 
 55    := unhexa (3 2) 
 56    := unhexa (5 2) 
 57   
 58   
 59  meta color e 
 60    var Link:Argument :> argument local ColorRGB888 
 61    if e:size=and e:0:ident="hsl" and (e:cast Float) and (e:cast Float) and (e:cast Float) 
 62      suckup e:1 ; suckup e:2 ; suckup e:3 
 63      add (instruction (the_function hsl_color Float Float Float -> ColorRGB888) e:1:result e:2:result e:3:result c) 
 64    eif e:size=and e:0:ident="rgb" and (e:cast Int) and (e:cast Int) and (e:cast Int) 
 65      suckup e:1 ; suckup e:2 ; suckup e:3 
 66      add (instruction (the_function rgb_color Int Int Int -> ColorRGB888) e:1:result e:2:result e:3:result c) 
 67    eif e:size=and e:0:ident="hexa" and (e:cast Str) 
 68      suckup e:1 
 69      add (instruction (the_function hexa_color Str -> ColorRGB888) e:1:result c) 
 70    eif e:size=and e:0:ident="html" and (e:cast Str) 
 71      suckup e:1 
 72      add (instruction (the_function html_color Str -> ColorRGB888) e:1:result c) 
 73    else 
 74      return 
 75    set_result access_read 
 76   
 77   
 78  function component255 i -> c 
 79    arg Int i ; arg Str c 
 80    check i>=and i<256 
 81    := right (string "radix 16") 2 "0" 
 82   
 83  method p 'to string' options -> s 
 84    arg ColorRGB888 p ; arg Str options s 
 85    := (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        := hexa_color str 
 94      eif str:len=and str:0="#" 
 95        := html_color str 
 96      eif (str parse word:"color" word:"rgb" (var Int r) (var Int g) (var Int b)) 
 97        := rgb_color b 
 98      eif (str parse word:"color" word:"hsl" (var Float h) (var Float s) (var Float l)) 
 99        := hsl_color 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      := cast p:r+(255-p:r)*Int 
 107      := cast p:g+(255-p:g)*Int 
 108      := cast p:b+(255-p:b)*Int 
 109    else 
 110      var Float := 1+l 
 111      := cast p:r*Int 
 112      := cast p:g*Int 
 113      := cast p:b*Int 
 114   
 115   
 116  export color shade 
 117   
 118   
 119   
 120   
 121   
 122   
 123