Patch title: Release 91 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 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 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.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) 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 := (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) 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) 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) 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
  field Float specular
  
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 ColorSpectrum32 f0 f50 f100
  field Float opacity
  field Float deaden
  field Float specular
  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
  cf specular := 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
  cf specular := ink specular

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
  var Float s := cf specular
  cf:rgb r += s ; cf:rgb g += s ; cf:rgb b += s
  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
  if f=undefined
    return
  var Float density := options option "density" Float 1
  if density<>1
    f := f^density
  var Float specular := options option "specular" Float 0
  var Float specular := options option "active_specular" Float (options option "specular" Float 0)
  if specular<>0
    f := max f-(cast specular ColorSpectrum32) (cast 0 ColorSpectrum32)
    f := max (1+specular)*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 (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 opacity := opt option "opacity" Float 0
      ink specular := opt option "specular" Float 0
      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
        var Float specular := options option "passive_specular" Float 0
        if specular<>0
          s := max (1+specular)*s-(cast specular ColorSpectrum32) (cast 0 ColorSpectrum32)
        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 f0 := cast 1 ColorSpectrum32
      if ink:s50<>undefined
        ink f50 := (2*ink:s50-0.5*ink:s0-0.5*ink:s100)/ink:s0
      else
        ink f50 := (ink:s0^0.5*ink:s100^0.5)/ink:s0
      ink f100 := ink:s100/ink:s0
      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 ""


export ColorInk 'cast Status' color_ink
export '. filter' '. gradation' '. s0' '. s100' '. opacity' '. deaden' '. maximum' '. options'
export '. filter' '. gradation' '. s0' '. s50' '. s100' '. f0' '. f50' '. f100' '. opacity' '. specular' '. maximum' '. options'
export ColorFast '. init' '. apply' '. terminate'