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"
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 standard_dot_growth 0.05
constant default_opacity 0
constant ink_cache 256
constant default_deaden 0
constant extrapolation_exposure 0.25



constant extrapolation_exposure 0.25



function ink_density color s0 s100 f err -> d
  arg ColorSpectrum32 color s0 s100 ; arg Function f ; arg_w
  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
  while step>=0.0001
    var ColorSpectrum32 got := ink_simulation d s0 s100 f
    var ColorSpectrum32 derive := (ink_simulation (min d+0.0
    var Float scalprod := (color-got)*derive*Y_spectrum inte
    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
    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
      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_spect


function ink_linear_simulation d s0 s100 -> s
  arg Float d ; arg ColorSpectrum32 s0 s100 ; arg ColorSpect
  s := (1-d)*s0+d*s100
 
function ink_linear color s0 s100 -> d
  arg ColorSpectrum32 color s0 s100 ; arg Float d
  err := ((color-got)*Y_spectrum):modulus/((s100-s0)*Y_spect


function ink_linear_simulation d s0 s100 -> s
  arg Float d ; arg ColorSpectrum32 s0 s100 ; arg ColorSpect
  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_si
  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 ColorSpect


function ink_thickness_simulation d s0 s100 -> s
  arg Float d ; arg ColorSpectrum32 s0 s100 ; arg ColorSpect
  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

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
  d := ink_density color s0 s100 (the_function ink_thickness_simulation Float ColorSpectrum32 ColorSpectrum32 -> ColorSpectrum32) 1 1 (var Float err)



function ink_surface color s0 s100 -> d
  arg ColorSpectrum32 color s0 s100 ; arg Float d



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_s
  d := ink_density color s0 s100 (the_function ink_surface_simulation Float ColorSpectrum32 ColorSpectrum32 -> ColorSpectrum32) 1 1 (var Float err)



function ink_density color s0 s100 -> d
  arg ColorSpectrum32 color s0 s100 ; arg Float d



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_s
  d := ink_density color s0 s100 (the_function ink_density_simulation Float ColorSpectrum32 ColorSpectrum32 -> ColorSpectrum32) 1 1 (var Float err)



type ColorFast
  field ColorRGB rgb



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
  
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_f
  field (Array ColorSpectrum32 encoded_resolution) filter
  field ColorGradation gradation
  field ColorSpectrum32 s0 s50 s100
  field (Array ColorInkFastFilter encoded_resolution) fast_f
  field (Array ColorSpectrum32 encoded_resolution) filter
  field ColorGradation gradation
  field ColorSpectrum32 s0 s50 s100
  field Float specular
  field Float opacity
  field Float opacity
  field Float deaden
  field Int maximum
  field Str options
  field Status status <- failure

  field Int maximum
  field Str options
  field Status status <- failure

CachePrototype maybe ColorInk


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


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

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

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



function color_ink name options -> ink
  arg Str name options ; arg Link:ColorInk ink
  rgb := cf rgb



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 St
    device_id := "default" ; channel_id := name
  var Data:ColorChannel channel :> color_database:data:devic
  if not exists:channel and (exists color_database:data:devi
    var Str alias := color_database:data:device:device_id:al
    channel :> color_database:data:device:device_id:channel:
  if channel:s0=undefined or channel:s100=undefined
    ink :> new ColorInk
    return
  var Str opt := options+" "+channel:options+" "+color_datab
  sem request
  var Pointer:Arrow c :> colors first string:name+" "+string
  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 10
  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 o
  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_re
    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 assum
      s := ink_surface_simulation d ink:s0 ink:s100
    else # we have more than three values, so we assume inkj
      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-(sample
      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) Color
    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:in
  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 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_rese
export '. filter' '. gradation' '. s0' '. s100' '. opacity' 
export ColorInk 'cast Status' color_ink
export '. filter' '. gradation' '. s0' '. s100' '. opacity' '. deaden' '. maximum' '. options'
export ColorFast '. init' '. apply' '. terminate'
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/spec
  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/spec
  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 := "from "+def
      color_database:data:device:"pantone":channel create na
      color_database:data:device:"pantone":channel:name:samp
      color_database:data:device:"pantone":channel:name:samp
      color_database:data:device:"pantone":channel:name:samp
      color_database:data:device:"pantone":channel:name:samp
 color_database store

export migrate