Patch title: Release 90 bulk changes
Abstract:
File: /graphic/color/ink.pli
Key:
    Removed line
    Added line
abstract
  [Inks simulation]


module "/pliant/language/compiler.pli"
module "/pliant/math/functions.pli"
module "/pliant/graphic/misc/float.pli"
module "spectrum.pli"
module "color.pli"
module "gradation.pli"
module "database.pli"
module "/pliant/language/data/cache.pli"
module "/pliant/language/compiler/type/inherit.pli"

constant standard_dot_growth 0.05
constant default_opacity 0
constant ink_cache 256
constant default_deaden 0
constant extrapolation_exposure 0.25


#-------------------------------------------------------------------------


function ink_simulation d s0 s100 f -> s
  arg Float d ; arg ColorSpectrum32 s0 s100 ; arg Function f ; arg ColorSpectrum32 s
  indirect

function ink_density color s0 s100 f err -> d
  arg ColorSpectrum32 color s0 s100 ; arg Function f ; arg_w Float err ; arg Float d
  d := 0.5 ; var Float step := 0.25
function ink_density color s0 s100 f mode maxi err -> d
  arg ColorSpectrum32 color s0 s100 ; arg Function f ; arg Int mode ; arg Float maxi ; arg_w Float err ; arg Float d
  # mode 0 = raw scalar product, 1 = weighed scalar product, 2 = cmc distance
  d := maxi/2 ; var Float step := maxi/4
  while step>=0.0001
    var ColorSpectrum32 got := ink_simulation d s0 s100 f
    var ColorSpectrum32 derive := (ink_simulation (min d+0.01 1) s0 s100 f)-(ink_simulation (max d-0.01 0) s0 s100 f)
    var Float scalprod := (color-got)*derive*Y_spectrum integral
    if scalprod>0
      d += step
    var ColorSpectrum32 derive := (ink_simulation (min d+0.02 maxi-0.01) s0 s100 f)-(ink_simulation (max d-0.02 0.01) s0 s100 f)
    # var ColorSpectrum32 derive := got-(cast 1 ColorSpectrum32)
    var Float scalprod
    if mode=0
      scalprod := (color-got)*derive integral
    else
      scalprod := (color-got)*derive*Y_spectrum integral
    if scalprod=undefined
      d := undefined
      err := undefined
      return
    eif scalprod>0
      d += step
    eif scalprod<0
      d -= step
    step := step*0.5
  if mode=2
    var ColorXYZ wished := filter_XYZ color/s0
    err := cmc_distance (filter_XYZ (ink_simulation d s0 s100 f)/s0) wished
    step := 0.01
    while step>=0.0001
      if d>=step and { var Float err2 := cmc_distance (filter_XYZ (ink_simulation d-step s0 s100 f)/s0) wished ; err2<err }
        d -= step ; err := err2
      eif d+step<=maxi and { var Float err2 := cmc_distance (filter_XYZ (ink_simulation d+step s0 s100 f)/s0) wished ; err2<err }
        d += step ; err := err2
      else
        step /= 2    
    got := ink_simulation d s0 s100 f
  err := ((color-got)*Y_spectrum):modulus/((s100-s0)*Y_spectrum):modulus


function ink_linear_simulation d s0 s100 -> s
  arg Float d ; arg ColorSpectrum32 s0 s100 ; arg ColorSpectrum32 s
  s := (1-d)*s0+d*s100
 
function ink_linear color s0 s100 -> d
  arg ColorSpectrum32 color s0 s100 ; arg Float d
  d := ink_density color s0 s100 (the_function ink_linear_simulation Float ColorSpectrum32 ColorSpectrum32 -> ColorSpectrum32) (var Float err)
  d := ink_density color s0 s100 (the_function ink_linear_simulation Float ColorSpectrum32 ColorSpectrum32 -> ColorSpectrum32) 1 1 (var Float err)


function ink_thickness_simulation d s0 s100 -> s
  arg Float d ; arg ColorSpectrum32 s0 s100 ; arg ColorSpectrum32 s
  s := s0^(1-d)*s100^d
  # s := s0^(1-d)*s100^d
  s := (s100/s0)^d*s0

function ink_thickness color s0 s100 -> d
  arg ColorSpectrum32 color s0 s100 ; arg Float d
  d := ink_density color s0 s100 (the_function ink_thickness_simulation Float ColorSpectrum32 ColorSpectrum32 -> ColorSpectrum32) (var Float err)
  d := ink_density color s0 s100 (the_function ink_thickness_simulation Float ColorSpectrum32 ColorSpectrum32 -> ColorSpectrum32) 1 1 (var Float err)


function ink_surface_simulation d s0 s50 s100 -> s
  arg Float d ; arg ColorSpectrum32 s0 s50 s100 ; arg ColorSpectrum32 s
  # s := (1-d)*(1-2*d)*s0+4*d*(1-d)*s50+d*(2*d-1)*s100
  s := (1-d)*(1-d)*s0+2*d*(1-d)*(2*s50-0.5*s0-0.5*s100)+d*d*s100

function ink_surface_simulation d s0 s100 -> s
  arg Float d ; arg ColorSpectrum32 s0 s100 ; arg ColorSpectrum32 s
  s := (1-d)*(1-d)*s0+2*d*(1-d)*(s0^0.5*s100^0.5)+d*d*s100

function ink_surface color s0 s100 -> d
  arg ColorSpectrum32 color s0 s100 ; arg Float d
  d := ink_density color s0 s100 (the_function ink_surface_simulation Float ColorSpectrum32 ColorSpectrum32 -> ColorSpectrum32) (var Float err)
  d := ink_density color s0 s100 (the_function ink_surface_simulation Float ColorSpectrum32 ColorSpectrum32 -> ColorSpectrum32) 1 1 (var Float err)


function ink_dot_growth d growth -> d2
  arg Float d growth d2
  d2 := d+4*growth*d*(1-d)

function ink_density_simulation d s0 s100 -> s
  arg Float d ; arg ColorSpectrum32 s0 s100 ; arg ColorSpectrum32 s
  s := ink_surface_simulation (ink_dot_growth d standard_dot_growth) s0 s100

function ink_density color s0 s100 -> d
  arg ColorSpectrum32 color s0 s100 ; arg Float d
  d := ink_density color s0 s100 (the_function ink_density_simulation Float ColorSpectrum32 ColorSpectrum32 -> ColorSpectrum32) (var Float err)
  d := ink_density color s0 s100 (the_function ink_density_simulation Float ColorSpectrum32 ColorSpectrum32 -> ColorSpectrum32) 1 1 (var Float err)


export ink_linear_simulation ink_linear
export ink_thickness_simulation ink_thickness
export ink_surface_simulation ink_surface
export ink_dot_growth
export ink_density_simulation ink_density


#-------------------------------------------------------------------------


type ColorFast
  field ColorRGB rgb
  field Float total maxi
  
type ColorInkFastFilter
  field Float32 r_filter r_generator
  field Float32 g_filter g_generator
  field Float32 b_filter b_generator

type ColorInk
  inherit CachePrototype
  field (Array ColorInkFastFilter encoded_resolution) fast_filter
  field (Array ColorSpectrum32 encoded_resolution) filter
  field ColorGradation gradation
  field ColorSpectrum32 s0 s50 s100
  field Float specular
  field Float opacity
  field Float deaden
  field Int maximum
  field Str options
  field Status status <- failure

CachePrototype maybe ColorInk

function 'cast Status' ink -> status
  arg ColorInk ink ; arg Status status
  extension
  status := ink status


gvar Dictionary colors
gvar Sem sem


doc
  [Here is how an ink is assumed to modify a color (fast and unaccurate algorithm):]

method cf init
  arg_w ColorFast cf
  cf:rgb r := 1 ; cf:rgb g := 1 ; cf:rgb b := 1
  cf total := 0 ; cf maxi := 0

method cf apply ink l
  arg_rw ColorFast cf ; arg ColorInk ink ; arg Int l
  var Pointer:ColorInkFastFilter p :> ink:fast_filter l
  cf:rgb r := cf:rgb:r*p:r_filter+p:r_generator
  cf:rgb g := cf:rgb:g*p:g_filter+p:g_generator
  cf:rgb b := cf:rgb:b*p:b_filter+p:b_generator
  var Float d := l/255*ink:deaden ; cf total += d ; cf maxi := max cf:maxi d

method cf terminate rgb
  arg_rw ColorFast cf ; arg_w ColorRGB888 rgb
  var Float d := cf:total-cf:maxi
  cf:rgb r += d ; cf:rgb g += d ; cf:rgb b += d
  rgb := cf rgb


doc
  [And this is the function that will load (compute and cache) the ink definition from the Pliant color database.]


function adjust f0 options quantity -> f
  arg ColorSpectrum32 f0 ; arg Str options ; arg Float quantity ; arg ColorSpectrum32 f
  f := f0
  var Float density := options option "density" Float 1
  if density<>1
    f := f^density
  var Float specular := options option "specular" Float 0
  if specular<>0
    f := max f-(cast specular ColorSpectrum32) (cast 0 ColorSpectrum32)
  if quantity>0
    for (var Int i) 0 3
      var Str color := shunt i=0 "cyan" i=1 "magenta" i=2 "yellow" "black"
      var Float extra := options option color Float
      if extra=defined
        var Data:ColorChannel primary :> color_database:data:device:"default":channel:color
        f *= (primary:s100/primary:s0)^(extra*quantity)

function color_ink name options -> ink
  arg Str name options ; arg Link:ColorInk ink
  if not (name parse any:(var Str device_id) ":" any:(var Str channel_id))
    device_id := "default" ; channel_id := name
  var Data:ColorChannel channel :> color_database:data:device:device_id:channel:channel_id
  if not exists:channel and (exists color_database:data:device:device_id:alias:channel_id)
    var Str alias := color_database:data:device:device_id:alias:channel_id
    channel :> color_database:data:device:device_id:channel:alias
  if channel:s0=undefined or channel:s100=undefined
    ink :> new ColorInk
    return
  var Str opt := options+" "+channel:options+" "+color_database:data:device:device_id:options
  sem request
  var Pointer:Arrow c :> colors first string:name+" "+string:opt
  if c<>null
    ink :> c map ColorInk
    sem release
    return
  if colors:count>=ink_cache
    colors := var Dictionary empty_dictionary
  ink :> new ColorInk
  ink s0 := adjust channel:s0 opt 0
  ink s50 := adjust channel:s50 opt 0.5
  ink s100 := adjust channel:s100 opt 1
  ink specular := opt option "specular" Float 0
  ink opacity := opt option "opacity" Float default_opacity
  ink maximum := opt option "maximum" Int 255
  var CBool negative := opt option "negative"
  var CBool linear := opt option "linear"
  var Int maxi := shunt (exists channel:sample:"255") 255 100
  ink options := opt
  var (Index Int ColorSpectrum32) samples
  each sample channel:sample
    if (keyof:sample parse (var Int index))
      samples insert index (adjust color_spectrum32:sample opt index/maxi)
  var Float dot := opt option "dot" Float 0
  for (var Int l) 0 encoded_resolution-1
    var Float d := ink_dot_growth (shunt negative encoded_resolution-1-l l)/(encoded_resolution-1) (shunt samples:size=2 dot 0)
    var ColorSpectrum32 s
    if samples:size=3 and ink:s50<>undefined
      s := ink_surface_simulation d ink:s0 ink:s50 ink:s100
    eif samples:size=2 # we have only 0 and 100% so we assume offset behaviour for the ink
      s := ink_surface_simulation d ink:s0 ink:s100
    else # we have more than three values, so we assume inkjet printer and we extrapolate between various provided samples
      var Pointer:ColorSpectrum32 a :> samples first
      var Pointer:ColorSpectrum32 b :> samples next a
      while (samples key b)<d*maxi
        a :> b ; b :> samples next a
      s := unexposure (ink_linear_simulation (d*maxi-(samples key a))/((samples key b)-(samples key a)) (exposure a extrapolation_exposure) (exposure b extrapolation_exposure)) extrapolation_exposure
      if not linear
        d := ink_surface s ink:s0 ink:s100
    ink:gradation:decode_table l := shunt negative 1-d d
    ink:filter l := s/ink:s0
    var Pointer:ColorInkFastFilter p :> ink:fast_filter l
    var ColorRGB rgb := cast (filter_XYZ ink:filter:l) ColorRGB
    rgb r := bound rgb:r 0 1
    rgb g := bound rgb:g 0 1
    rgb b := bound rgb:b 0 1
    var Float o := l/(encoded_resolution-1)*ink:opacity
    p r_filter := (1-o)*rgb:r ; p r_generator := o*rgb:r
    p g_filter := (1-o)*rgb:g ; p g_generator := o*rgb:g
    p b_filter := (1-o)*rgb:b ; p b_generator := o*rgb:b
  ink status := success
  ink:gradation compute
  if ink:gradation=failure
    ink status := failure
  colors insert string:name+" "+string:opt true addressof:ink
  sem release
  if (cache_open "/pliant/color/ink/"+string:name+options ColorInk ((addressof Link:ColorInk ink) map Link:CachePrototype))
    part build
      if not (name parse any:(var Str device_id) ":" any:(var Str channel_id))
        device_id := "default" ; channel_id := name
      var Data:ColorChannel channel :> color_database:data:device:device_id:channel:channel_id
      if not exists:channel and (exists color_database:data:device:device_id:alias:channel_id)
        var Str alias := color_database:data:device:device_id:alias:channel_id
        channel :> color_database:data:device:device_id:channel:alias
      if channel:s0=undefined or channel:s100=undefined
        ink status := failure
        leave build
      var Str opt := options+" "+channel:options+" "+color_database:data:device:device_id:options
      ink s0 := adjust channel:s0 opt 0
      ink s50 := adjust channel:s50 opt 0.5
      ink s100 := adjust channel:s100 opt 1
      if (opt option "align" Str)<>""
        if not ((opt option "align" Str) parse any:(var Str align_device) ":" any:(var Str align_color))
          ink status := failure
          leave build
        var Data:ColorChannel align :> color_database:data:device:align_device:channel:align_color
        if align:s0=failure or align:s100=failure
          ink status := failure
          leave build
        var Float d := ink_density align:s100/align:s0*ink:s0 ink:s0 ink:s100 (the_function ink_thickness_simulation Float ColorSpectrum32 ColorSpectrum32 -> ColorSpectrum32) 2 2 (var Float err)
        console "align for ink " device_id " " channel_id " is " (string d "fixed 3") eol
        ink s100 := (ink:s100/ink:s0)^d*ink:s0
      ink opacity := opt option "opacity" Float default_opacity
      ink deaden := opt option "deaden" Float default_deaden
      ink maximum := opt option "maximum" Int 255
      var CBool negative := opt option "negative"
      var CBool linear := opt option "linear"
      var CBool thickness := opt option "thickness"
      var Int maxi := shunt (exists channel:sample:"255") 255 100
      ink options := opt
      var (Index Int ColorSpectrum32) samples
      each sample channel:sample
        if (keyof:sample parse (var Int index))
          samples insert index (adjust color_spectrum32:sample opt index/maxi)
      var Float dot := opt option "dot" Float 0
      for (var Int l) 0 encoded_resolution-1
        var Float d := ink_dot_growth (shunt negative encoded_resolution-1-l l)/(encoded_resolution-1) (shunt samples:size=2 dot 0)
        var ColorSpectrum32 s
        if samples:size=3 and ink:s50<>undefined
          s := ink_surface_simulation d ink:s0 ink:s50 ink:s100
        eif samples:size=2 # we have only 0 and 100% so we assume offset behaviour for the ink
          s := ink_surface_simulation d ink:s0 ink:s100
        else # we have more than three values, so we assume inkjet printer and we extrapolate between various provided samples
          var Pointer:ColorSpectrum32 a :> samples first
          var Pointer:ColorSpectrum32 b :> samples next a
          while (samples key b)<d*maxi
            a :> b ; b :> samples next a
          s := unexposure (ink_linear_simulation (d*maxi-(samples key a))/((samples key b)-(samples key a)) (exposure a extrapolation_exposure) (exposure b extrapolation_exposure)) extrapolation_exposure
          if not linear
            d := ink_surface s ink:s0 ink:s100
        if thickness
          var Float d2 := ink_thickness s ink:s0 ink:s100
          s := ink_thickness_simulation d2 ink:s0 ink:s100
        ink:gradation:decode_table l := shunt negative 1-d d
        ink:filter l := s/ink:s0
        var Pointer:ColorInkFastFilter p :> ink:fast_filter l
        var ColorRGB rgb := cast (filter_XYZ ink:filter:l) ColorRGB
        rgb r := bound rgb:r 0 1
        rgb g := bound rgb:g 0 1
        rgb b := bound rgb:b 0 1
        var Float o := l/(encoded_resolution-1)*ink:opacity*ink:opacity
        p r_filter := (1-o)*rgb:r ; p r_generator := o*rgb:r
        p g_filter := (1-o)*rgb:g ; p g_generator := o*rgb:g
        p b_filter := (1-o)*rgb:b ; p b_generator := o*rgb:b
      ink status := success
      ink:gradation compute
      if ink:gradation=failure
        ink status := failure
    if ink:status=success
      cache_ready ((addressof Link:ColorInk ink) map Link:CachePrototype)
    else
      cache_cancel ((addressof Link:ColorInk ink) map Link:CachePrototype)


function color_ink name -> ink
  arg Str name ; arg Link:ColorInk ink
  ink :> color_ink name ""


function color_ink_cache_reset
  sem request
  colors := var Dictionary empty_dictionary
  sem release


export ColorInk 'cast Status' color_ink color_ink_cache_reset
export '. filter' '. gradation' '. s0' '. s100' '. opacity' '. maximum' '. options'
export ColorInk 'cast Status' color_ink
export '. filter' '. gradation' '. s0' '. s100' '. opacity' '. deaden' '. maximum' '. options'
export ColorFast '. init' '. apply' '. terminate'


module "/pliant/language/stream.pli"

function migrate
  color_database:data:device create "pantone"     
  (var Stream s) open "file:/pliant/helio/graphic/color/spectrum.txt" in
  while s:readline<>""
    if (s:readline parse word:"white" any:(var Str def))
      var Str white := def
  (var Stream s) open "file:/pliant/helio/graphic/color/spectrum.txt" in
  while s:readline<>""
    void
  while not s:atend
    var Str l := s readline
    if (l parse any:(var Str name) word:"from" any:(var Str def))
      def := "from "+def
      color_database:data:device:"pantone":channel create name
      color_database:data:device:"pantone":channel:name:sample create "0"
      color_database:data:device:"pantone":channel:name:sample:"0" := white
      color_database:data:device:"pantone":channel:name:sample create "100"
      color_database:data:device:"pantone":channel:name:sample:"100" := def
 color_database store

export migrate