Patch title: Release 85 bulk changes
Abstract:
File: /pliant/graphic/color/rgb888.pli
Key:
    Removed line
    Added line
   
module "/pliant/language/compiler.pli"


public
  type ColorRGB888
    field uInt8 r g b


function rgb_color r g b -> p
  arg Int r g b ; arg ColorRGB888 p
  p r := r ; p g := g ; p b := b

function hsl_color h s l -> p
  arg Float h s l ; arg ColorRGB888 p
  check h>=0 and h<360
  for (var Int i) 0 2
    var Float hi := h-120*i
    while hi<(-180)
      hi += 360
    while hi>=180
      hi -= 360
    var Float f := shunt hi<0 (1/60)*hi+2 -(1/60)*hi+2
    f := shunt f<=0 0 f>=1 1 f
    # f :=  f*s/100 + l/100*(1-s/100)
    f :=  f*s/100 + 0.5*(1-s/100)
    if l>50
      f := f+(1-f)*0.02*(l-50)
    else
      f *= l/50
    (addressof:p translate uInt8 i) map uInt8 := cast f*255 uInt

function unhexa s -> i
  arg Str s ; arg Int i
  i := 0
  for (var Int j) 0 s:len-1
    var Int c := s:j number
    if c>="0":0:number and c<="9":0:number
      i := i*16+(c-"0":0:number)
    eif c>="A":0:number and c<="F":0:number
      i := i*16+(c-"A":0:number+10)
    eif c>="a":0:number and c<="f":0:number
      i := i*16+(c-"a":0:number+10)
    else
      return undefined

function hexa_color s -> p
  arg Str s ; arg ColorRGB888 p
  p r := unhexa (s 0 2)
  p g := unhexa (s 2 2)
  p b := unhexa (s 4 2)

function html_color s -> p
  arg Str s ; arg ColorRGB888 p
  p r := unhexa (s 1 2)
  p g := unhexa (s 3 2)
  p b := unhexa (s 5 2)


meta color e
  var Link:Argument c :> argument local ColorRGB888
  if e:size=4 and e:0:ident="hsl" and (e:1 cast Float) and (e:2 cast Float) and (e:3 cast Float)
    e suckup e:1 ; e suckup e:2 ; e suckup e:3
    e add (instruction (the_function hsl_color Float Float Float -> ColorRGB888) e:1:result e:2:result e:3:result c)
  eif e:size=4 and e:0:ident="rgb" and (e:1 cast Int) and (e:2 cast Int) and (e:3 cast Int)
    e suckup e:1 ; e suckup e:2 ; e suckup e:3
    e add (instruction (the_function rgb_color Int Int Int -> ColorRGB888) e:1:result e:2:result e:3:result c)
  eif e:size=2 and e:0:ident="hexa" and (e:1 cast Str)
    e suckup e:1
    e add (instruction (the_function hexa_color Str -> ColorRGB888) e:1:result c)
  eif e:size=2 and e:0:ident="html" and (e:1 cast Str)
    e suckup e:1
    e add (instruction (the_function html_color Str -> ColorRGB888) e:1:result c)
  else
    return
  e set_result c access_read


function component255 i -> c
  arg Int i ; arg Str c
  check i>=0 and i<256
  c := right (string i "radix 16") 2 "0"

method p 'to string' options -> s
  arg ColorRGB888 p ; arg Str options s
  s := (shunt options="html" "#" "")+(component255 p:r)+(component255 p:g)+(component255 p:b)

method p 'from string' string options may_skip skiped offset -> status
  arg_w ColorRGB888 p ; arg Str string options ; arg CBool may_skip ; arg_w Int skiped offset ; arg Status status
  var Link:Str str :> new Str
  status := str 'from string' string options may_skip skiped offset
  if status=success
    if str:len=6
      p := hexa_color str
    eif str:len=7 and str:0="#"
      p := html_color str
    eif (str parse word:"color" word:"rgb" (var Int r) (var Int g) (var Int b))
      p := rgb_color r g b
    eif (str parse word:"color" word:"hsl" (var Float h) (var Float s) (var Float l))
      p := hsl_color h s l
    else
      status := failure

function shade p l -> q
  arg ColorRGB888 p ; arg Float l ; arg ColorRGB888 q
  if l>0
    q r := cast p:r+(255-p:r)*l Int
    q g := cast p:g+(255-p:g)*l Int
    q b := cast p:b+(255-p:b)*l Int
  else
    var Float m := 1+l
    q r := cast p:r*m Int
    q g := cast p:g*m Int
    q b := cast p:b*m Int


export color shade