Patch title: Release 93 bulk changes
Abstract:
File: /graphic/color/gamut.pli
Key:
    Removed line
    Added line
   
abstract
  ['ColorGamut' data type is defining how a pixel is encoded


constant hash_conversion true
constant hash_rgb true
abstract
  ['ColorGamut' data type is defining how a pixel is encoded


constant hash_conversion true
constant hash_rgb true
constant logarithm_grid true







method g formulate color options pixel
  oarg ColorGamutRGB g ; arg ColorXYZ color ; arg Str option
  var ColorRGB888 rgb := cast color ColorRGB888
  if g:reversed
    for (var Int c) 0 2
      pixel map uInt8 c := addressof:rgb map uInt8 2-c
  else
    pixel map ColorRGB888 := rgb


#-----------------------------------------------------------
method g formulate color options pixel
  oarg ColorGamutRGB g ; arg ColorXYZ color ; arg Str option
  var ColorRGB888 rgb := cast color ColorRGB888
  if g:reversed
    for (var Int c) 0 2
      pixel map uInt8 c := addressof:rgb map uInt8 2-c
  else
    pixel map ColorRGB888 := rgb


#-----------------------------------------------------------
#   additive (XYZ)


type ColorGamutXYZ
  inherit ColorGamut
  
ColorGamut maybe ColorGamutXYZ


method g decode pixel components
  oarg ColorGamutXYZ g ; arg Address pixel ; arg_w (Array Float32 gamut_maximum_dimension) components
  memory_copy pixel addressof:components 3*Float32:size

method g encode components pixel
  oarg ColorGamutXYZ g ; arg (Array Float32 gamut_maximum_dimension) components ; arg Address pixel
  memory_copy addressof:components pixel 3*Float32:size
  
method g simulate pixel -> color
  oarg ColorGamutXYZ g ; arg Address pixel ; arg ColorXYZ color
  memory_copy pixel addressof:color 3*Float32:size

method g formulate color options pixel
  oarg ColorGamutXYZ g ; arg ColorXYZ color ; arg Str options ; arg Address pixel
  memory_copy addressof:color pixel 3*Float32:size


#-------------------------------------------------------------------------
#   grid based conversion


constant grid_conversion_release 11
constant grid_conversion_cache 16


type ColorGridConversion
  inherit CachePrototype
  field Array:Float32 mapping
  field Int dim
  field Int steps
  field Int done
  field Str key

CachePrototype maybe ColorGridConversion


method conv compute src_gamut dest_gamut steps cached
  arg_w ColorGridConversion conv ; oarg ColorGamut src_gamut dest_gamut ; arg Int steps ; arg CBool cached
  var Int dim := src_gamut dimension
  conv dim := dim
  conv steps := steps
  conv:mapping size := steps^dim*dest_gamut:dimension
  for (var Int i) 0 steps^dim-1
    conv:mapping i*dest_gamut:dimension := undefined
  conv done := 0
  if cached
    conv key := string_md5_hexa_signature (string src_gamut:name)+" "+string:(src_gamut query "signature")+" "+(string dest_gamut:name)+" "+string:(dest_gamut query "signature")+" "+string:steps+" "+string:grid_conversion_release
    (var Stream s) open "data:/pliant/graphic/cache/"+conv:key+".bin" in+safe
    if s=success
      while s:readline<>""
        void
      s raw_read (addressof conv:mapping:0) conv:mapping:size*Float32:size
      if s=success
        for (var Int i) 0 steps^dim-1
          if (conv:mapping i*dest_gamut:dimension)=defined
            conv:done += 1
      else
        for (var Int i) 0 steps^dim-1
          conv:mapping i*dest_gamut:dimension := undefined

method conv compute_node index src_gamut dest_gamut
  arg_rw ColorGridConversion conv ; arg Int index ; oarg ColorGamut src_gamut dest_gamut
  var Str options := dest_gamut query "options"
  var Pointer:Float32 p :> conv:mapping index*dest_gamut:dimension
  var ColorBuffer src_pixel dest_pixel
  for (var Int d) 0 conv:dim-1
    src_pixel:bytes d := (index\conv:steps^d)%conv:steps*255\(conv:steps-1)
  var ColorXYZ color := src_gamut simulate addressof:src_pixel
  color_adjust color options
  dest_gamut formulate color addressof:dest_pixel
  dest_gamut decode addressof:dest_pixel (var (Array Float32 gamut_maximum_dimension) components)
  for (var Int d) dest_gamut:dimension-1 0 step -1
    addressof:p map Float32 d := components d
  conv done += 1

method conv compute_node2 index src_gamut dest_gamut
  arg_rw ColorGridConversion conv ; arg Int index ; oarg ColorGamut src_gamut dest_gamut
  var CBool hurry := dest_gamut:name="XYZ"
  # if not hurry
  #   console "compute lazy color conversion grid node "+(string conv:done)+"/"+(string conv:steps^conv:dim)+" ("+src_gamut:name+" -> "+dest_gamut:name+")   [cr]"
  part compute "compute lazy color conversion grid node "+(string conv:done)+"/"+(string conv:steps^conv:dim)+" ("+src_gamut:name+" -> "+dest_gamut:name+")"
    conv compute_node index src_gamut dest_gamut
  if conv:key<>""
    if conv:done%(shunt hurry 4096 256)=0 or conv:done=conv:steps^conv:dim
      (var Stream s) open "data:/pliant/graphic/cache/"+conv:key+".bin" out+safe+mkdir
      s writeline "Pliant color conversion"
      s writeline "source_gamut "+(string src_gamut:name)
      s writeline "source_options "+string:(src_gamut query "signature")
      s writeline "destination_gamut "+(string dest_gamut:name)
      s writeline "destination_options "+string:(dest_gamut query "signature")
      s writeline "steps "+(string conv:steps)
      s writeline "release "+string:grid_conversion_release
      s writeline ""
      s raw_write (addressof conv:mapping:0) conv:mapping:size*Float32:size
      s close
      # if not hurry
      #   console "."

method conv apply src_pixel src_gamut dest_pixel dest_gamut
  arg_rw ColorGridConversion conv ; arg Address src_pixel ; oarg ColorGamut src_gamut ; arg Address dest_pixel ; oarg ColorGamut dest_gamut
  var Int dim := conv dim ; var Int steps := conv steps
  var Int base := 0  
  var Int n := 0
  var (Array Int gamut_maximum_dimension) gs # grid step
  var (Array Float gamut_maximum_dimension) remain
  check src_gamut:pixel_size=src_gamut:dimension
  var Int unit := 1
  for (var Int d) 0 src_gamut:dimension-1
    var Int v := src_pixel map uInt8 d
    if v=0
      void
    eif v=255
      base += (steps-1)*unit
    else
      var Int i := min v*(steps-1)\255 steps-2
      gs n := unit
      base += i*unit
      remain n := ( v - i*255\(steps-1) ) / ( (i+1)*255\(steps-1) - i*255\(steps-1) )
      n += 1
    unit *= steps
  var (Array Float32 gamut_maximum_dimension) result
  for (var Int d) 0 dest_gamut:dimension-1
    result d := 0
  for (var Int u) 0 2^n-1
    var Int index := base ; var Float f := 1
    for (var Int d) 0 n-1
      if (u .and. 2^d)<>0
        index += gs d
        f *= remain d
      else
        f *= 1-remain:d
    var Pointer:Float32 p :> conv:mapping index*dest_gamut:dimension
    if p=undefined
      conv compute_node2 index src_gamut dest_gamut
    for (var Int d) 0 dest_gamut:dimension-1
      result d += f*p
      p :> addressof:p map Float32 1
  dest_gamut encode result dest_pixel


function color_grid_conversion src_gamut dest_gamut steps cached -> conv
  oarg ColorGamut src_gamut dest_gamut ; arg Int steps ; arg CBool cached ; arg Link:ColorGridConversion conv
  var Str k := (string src_gamut:name)+" "+string:(src_gamut query "signature")+" "+(string dest_gamut:name)+" "+string:(dest_gamut query "signature")
  if (cache_open "/pliant/color/grid/"+k ColorGridConversion ((addressof Link:ColorGridConversion conv) map Link:CachePrototype))
    var Int dim := src_gamut dimension
    conv compute src_gamut dest_gamut (shunt steps=defined steps src_gamut:model=color_gamut_additive 33 dim<=4 17 dim<=6 9 5) cached
    cache_ready ((addressof Link:ColorGridConversion conv) map Link:CachePrototype)


#-------------------------------------------------------------------------
#   substractive (inks)



type ColorGamutSubstractive
  inherit ColorGamut
  field Array:ColorComponent component
  field Str device options
  field Float deaden <- 0
  field CBool composed <- false
  field CBool multiple_transparency <- false
  field CBool no_opacity <- false
  field CBool reverse_printing <- false
  field Int negatives <- 0
#   substractive (inks)



type ColorGamutSubstractive
  inherit ColorGamut
  field Array:ColorComponent component
  field Str device options
  field Float deaden <- 0
  field CBool composed <- false
  field CBool multiple_transparency <- false
  field CBool no_opacity <- false
  field CBool reverse_printing <- false
  field Int negatives <- 0
  field Link:ColorGridConversion fast_simulation
  field Link:ColorGamut another_gamut
  field Link:ColorGamut xyz_gamut
  
ColorGamut maybe ColorGamutSubstractive



method gamut dispatch_pixel pixel plus minus
  arg ColorGamutSubstractive gamut ; arg Address pixel plus 
  if gamut:composed
    memory_clear plus gamut:component:size
    memory_copy pixel plus gamut:dimension
    memory_clear minus gamut:component:size
    for (var Int i) gamut:dimension gamut:component:size-1
      var Pointer:ColorComponent c :> gamut:component i
      if (exists c:curve)
        for (var Int j) 0 c:indice:size-1
  
ColorGamut maybe ColorGamutSubstractive



method gamut dispatch_pixel pixel plus minus
  arg ColorGamutSubstractive gamut ; arg Address pixel plus 
  if gamut:composed
    memory_clear plus gamut:component:size
    memory_copy pixel plus gamut:dimension
    memory_clear minus gamut:component:size
    for (var Int i) gamut:dimension gamut:component:size-1
      var Pointer:ColorComponent c :> gamut:component i
      if (exists c:curve)
        for (var Int j) 0 c:indice:size-1
          plus map uInt8 c:indice:j := 0
          var Int k := c:indice j
          if k<>undefined
            minus map uInt8 k := plus map uInt8 k
        plus map uInt8 i := 1
    for (var Int i) gamut:dimension gamut:component:size-1
      var Pointer:ColorComponent c :> gamut:component i
      if not (exists c:curve)
        var Int m := 255
        for (var Int j) 0 c:indice:size-1
          m := min m (plus map uInt8 c:indice:j)
        plus map uInt8 i := m
    for (var Int i) gamut:dimension gamut:component:size-1
      var Pointer:ColorComponent ci :> gamut:component i
      if not (exists ci:curve)
        for (var Int j) 0 gamut:component:size-1
          var Pointer:ColorComponent cj :> gamut:component j
          if (ci:mask .or. cj:mask)=ci:mask and i<>j
            minus map uInt8 j := max (cast (minus map uInt8 
  else
    memory_copy pixel plus gamut:dimension
    memory_clear minus gamut:dimension

function curven_simulation c pixel -> f
  arg ColorComponent c ; arg Address pixel ; arg ColorSpectr
  (var Array:Float params) size := c:indice size
  for (var Int i) 0 params:size-1
    var Int j := c:indice i
    if j<>undefined
      params i := pixel map uInt8 j
    else
      params i := 0
  var Array:Float point := c:curve apply params
  check point:size=ColorSpectrum32:size\Float32:size
  for (var Int i) 0 point:size-1
    for (var Int i) gamut:dimension gamut:component:size-1
      var Pointer:ColorComponent c :> gamut:component i
      if not (exists c:curve)
        var Int m := 255
        for (var Int j) 0 c:indice:size-1
          m := min m (plus map uInt8 c:indice:j)
        plus map uInt8 i := m
    for (var Int i) gamut:dimension gamut:component:size-1
      var Pointer:ColorComponent ci :> gamut:component i
      if not (exists ci:curve)
        for (var Int j) 0 gamut:component:size-1
          var Pointer:ColorComponent cj :> gamut:component j
          if (ci:mask .or. cj:mask)=ci:mask and i<>j
            minus map uInt8 j := max (cast (minus map uInt8 
  else
    memory_copy pixel plus gamut:dimension
    memory_clear minus gamut:dimension

function curven_simulation c pixel -> f
  arg ColorComponent c ; arg Address pixel ; arg ColorSpectr
  (var Array:Float params) size := c:indice size
  for (var Int i) 0 params:size-1
    var Int j := c:indice i
    if j<>undefined
      params i := pixel map uInt8 j
    else
      params i := 0
  var Array:Float point := c:curve apply params
  check point:size=ColorSpectrum32:size\Float32:size
  for (var Int i) 0 point:size-1
    addressof:f map Float32 i := point i
    if logarithm_grid
      addressof:f map Float32 i := exp point:i
    else
      addressof:f map Float32 i := point i


method gamut simulate pixel -> color
  oarg ColorGamutSubstractive gamut ; arg Address pixel ; ar


method gamut simulate pixel -> color
  oarg ColorGamutSubstractive gamut ; arg Address pixel ; ar
  color := filter_XYZ (gamut simulate2 pixel)
  color_adjust color (gamut:options option "gamut_adjust" St
  if (exists gamut:fast_simulation)
    ((addressof gamut:fast_simulation) omap ColorGridConversion) apply pixel gamut:another_gamut addressof:color gamut:xyz_gamut
  else
    color := filter_XYZ (gamut simulate2 pixel)
    color_adjust color (gamut:options option "gamut_adjust" Str)



method gamut formulate color options pixel
  oarg ColorGamutSubstractive gamut ; arg ColorXYZ color ; a
  var Str opt := options+" "+(gamut query "options")



method gamut formulate color options pixel
  oarg ColorGamutSubstractive gamut ; arg ColorXYZ color ; a
  var Str opt := options+" "+(gamut query "options")
  if not ((opt (options option_position "removal" 0) options
  if not ((opt (opt option_position "removal" 0) opt:len) parse word:"removal" (var Int b0) (var Int b1) any)
    b0 := 0 ; b1 := 0
  var Float epsilon := opt option "epsilon" Float 0.5
    b0 := 0 ; b1 := 0
  var Float epsilon := opt option "epsilon" Float 0.5
  var Float l := opt option "l" Float cmc_distance_l_paramet
  var Float c := opt option "c" Float cmc_distance_c_paramet
  var Float l := opt option "cmc_l" Float cmc_distance_l_parameter
  var Float c := opt option "cmc_c" Float cmc_distance_c_parameter
  if gamut:dimension>=4
    var Int darkest := opt option "darkest" Int
    if darkest=undefined
      darkest := 0 ; var Float Ymini := 1e6
      for (var Int i) 0 gamut:dimension-1
        var Float Y := (filter_XYZ gamut:component:i:ink:s10
        if Y<Ymini
          darkest := i ; Ymini := Y
    var Float distance := 1e10
    (var Array:Int using) size := 3 ; using 2 := darkest
    for using:0 0 gamut:dimension-1
      for using:1 using:0+1 gamut:dimension-1
        if using:0<>darkest and using:1<>darkest
          memory_clear addressof:(var ColorBuffer test) gamu
          var Float d := gamut try_formulate color addressof
          if d<distance
            memory_copy addressof:test pixel gamut:pixel_siz
  if gamut:dimension>=4
    var Int darkest := opt option "darkest" Int
    if darkest=undefined
      darkest := 0 ; var Float Ymini := 1e6
      for (var Int i) 0 gamut:dimension-1
        var Float Y := (filter_XYZ gamut:component:i:ink:s10
        if Y<Ymini
          darkest := i ; Ymini := Y
    var Float distance := 1e10
    (var Array:Int using) size := 3 ; using 2 := darkest
    for using:0 0 gamut:dimension-1
      for using:1 using:0+1 gamut:dimension-1
        if using:0<>darkest and using:1<>darkest
          memory_clear addressof:(var ColorBuffer test) gamu
          var Float d := gamut try_formulate color addressof
          if d<distance
            memory_copy addressof:test pixel gamut:pixel_siz
    if (options option "removal") and gamut:dimension=4 and 
    if (opt option "removal") and gamut:dimension=4 and darkest=3
      using 0 := 0 ; using 1 := 1 ; using 2 := 2
      memory_clear addressof:test gamut:pixel_size ; test:by
      var Float d := gamut try_formulate color addressof:tes
      if d<distance
        memory_copy addressof:test pixel gamut:pixel_size ; 
      var Int black := pixel map uInt8 3
      if black>=b1
        void
      eif black<b0
        black := 0
      else
        black := b1*(black-b0)\(b1-b0)
      gamut fill_pixel addressof:test ; test:bytes 3 := blac
      using 0 := 0 ; using 1 := 1 ; using 2 := 2
      d := gamut try_formulate color addressof:test using l 
      if d<distance or d<epsilon
        memory_copy addressof:test pixel gamut:pixel_size ; 
  else
    gamut fill_pixel pixel
    (var Array:Int using) size := gamut dimension
    for (var Int i) 0 using:size-1
      using i := i
    gamut try_formulate color pixel using l c



function color_gamut name options -> g
  arg Str name options ; arg Link:ColorGamut g
  var Pointer:Type t
  if (name parse any:(var Str device) ":" any:(var Str inks)
    t :> ColorGamutSubstractive
  eif name="grey"
    t :> ColorGamut
      using 0 := 0 ; using 1 := 1 ; using 2 := 2
      memory_clear addressof:test gamut:pixel_size ; test:by
      var Float d := gamut try_formulate color addressof:tes
      if d<distance
        memory_copy addressof:test pixel gamut:pixel_size ; 
      var Int black := pixel map uInt8 3
      if black>=b1
        void
      eif black<b0
        black := 0
      else
        black := b1*(black-b0)\(b1-b0)
      gamut fill_pixel addressof:test ; test:bytes 3 := blac
      using 0 := 0 ; using 1 := 1 ; using 2 := 2
      d := gamut try_formulate color addressof:test using l 
      if d<distance or d<epsilon
        memory_copy addressof:test pixel gamut:pixel_size ; 
  else
    gamut fill_pixel pixel
    (var Array:Int using) size := gamut dimension
    for (var Int i) 0 using:size-1
      using i := i
    gamut try_formulate color pixel using l c



function color_gamut name options -> g
  arg Str name options ; arg Link:ColorGamut g
  var Pointer:Type t
  if (name parse any:(var Str device) ":" any:(var Str inks)
    t :> ColorGamutSubstractive
  eif name="grey"
    t :> ColorGamut
  eif name="XYZ"
    t :> ColorGamutXYZ
  else
    t :> ColorGamutRGB
  plugin extra_types
  if (cache_open "/pliant/color/gamut/"+string:name+options 
    g name := name
    part build
      if t=ColorGamut
        g pixel_size := 1
        g dimension := 1
        g model := color_gamut_additive
        g status := success
      eif t=ColorGamutRGB
        var Pointer:ColorGamutRGB ga :> addressof:g map Colo
        if name="rgb"
          rgb_gamut ga name 0 0 false options
        eif name="rgb32"
          rgb_gamut ga name 0 1 false options
        eif name="bgr"
          rgb_gamut ga name 0 0 true options
        eif name="bgr32"
          rgb_gamut ga name 0 1 true options
        eif name="rgba"
          rgb_gamut ga name 1 0 false options
        else
          g status := failure
  else
    t :> ColorGamutRGB
  plugin extra_types
  if (cache_open "/pliant/color/gamut/"+string:name+options 
    g name := name
    part build
      if t=ColorGamut
        g pixel_size := 1
        g dimension := 1
        g model := color_gamut_additive
        g status := success
      eif t=ColorGamutRGB
        var Pointer:ColorGamutRGB ga :> addressof:g map Colo
        if name="rgb"
          rgb_gamut ga name 0 0 false options
        eif name="rgb32"
          rgb_gamut ga name 0 1 false options
        eif name="bgr"
          rgb_gamut ga name 0 0 true options
        eif name="bgr32"
          rgb_gamut ga name 0 1 true options
        eif name="rgba"
          rgb_gamut ga name 1 0 false options
        else
          g status := failure
      eif t=ColorGamutXYZ
        g pixel_size := 3*Float32:size
        g dimension := 3
        g model := color_gamut_additive
        g status := success
      eif t=ColorGamutSubstractive
        var Pointer:ColorGamutSubstractive gs :> addressof:g
        gs model := color_gamut_substractive
        gs device := device
        gs options := color_database:data:device:device opti
        gs deaden := gs:options option "deaden" Float 0
        gs no_opacity := options option "no_opacity"
        inks := replace inks "cmyk" "process_cyan+process_ma
        while inks<>""
      eif t=ColorGamutSubstractive
        var Pointer:ColorGamutSubstractive gs :> addressof:g
        gs model := color_gamut_substractive
        gs device := device
        gs options := color_database:data:device:device opti
        gs deaden := gs:options option "deaden" Float 0
        gs no_opacity := options option "no_opacity"
        inks := replace inks "cmyk" "process_cyan+process_ma
        while inks<>""
          if not (inks parse any:(var Str ink) "+" any:(var 
          if not (inks eparse any:(var Str ink) "+" any:(var Str remain))
            ink := inks ; remain := ""
          if ink="transparency"
            gs transparency := 1
          eif ink="transparencies"
            gs multiple_transparency := true
          else
            gs:component size := dim+1
            var Pointer:ColorComponent gc :> gs:component di
            gc name := ink
            ink := inks ; remain := ""
          if ink="transparency"
            gs transparency := 1
          eif ink="transparencies"
            gs multiple_transparency := true
          else
            gs:component size := dim+1
            var Pointer:ColorComponent gc :> gs:component di
            gc name := ink
            if (ink parse any:(var Str base) "#" any)
            if (ink eparse any:(var Str base) "#" any)
              ink := base
            gc ink :> color_ink (shunt (ink search ":" -1)=(
            if gc:ink=failure
              g status := failure (shunt (exists color_datab
              leave build
            gc mask := 2^dim
            if (gc:ink:options option "negative")
              gs negatives += 2^dim
            dim += 1
            if (gc:ink:options option "reverse_printing")
              gs reverse_printing := true
            if (ink search ":" -1)<>(-1) and (gc:ink:options
              gs deaden := gc:ink deaden
          inks := remain
        if gs:multiple_transparency 
          gs transparency := dim
        gs dimension := dim
        gs pixel_size := gs:dimension+gs:transparency
        var Str opt := options+" "+color_database:data:devic
        if (opt option "composed")
          each ch color_database:data:device:device:channel 
            if (keyof:ch search "+" -1)<>(-1)
              if (gs add_component device+":" keyof:ch)=succ
                gs composed := true
        var Str measure := options option "measure" Str devi
        (var Stream s) open "data:/pliant/graphic/gamut/"+me
        if s=success
          gs:component size += 1
          var Pointer:ColorComponent c :> gs:component gs:co
          var Int count := 0
          c:indice size := 0
          var (Array Array:Float) grid
          while not s:atend and { var Str l := s readline ; 
            if (l parse word:"ink" (var Str inkname) any:(va
              grid size += 1
              while (values parse (var Float f) any:(var Str
                grid grid:size-1 += f
                values := remain
              c indice += undefined
              for (var Int i) 0 gs:dimension-1
                if gs:component:i:name=inkname
                  c:indice c:indice:size-1 := i
              if (c:indice c:indice:size-1)<>undefined
                count += 1
          if count>=2
            c curve :> new Curven
            c:curve resize ColorSpectrum32:size\Float32:size
              ink := base
            gc ink :> color_ink (shunt (ink search ":" -1)=(
            if gc:ink=failure
              g status := failure (shunt (exists color_datab
              leave build
            gc mask := 2^dim
            if (gc:ink:options option "negative")
              gs negatives += 2^dim
            dim += 1
            if (gc:ink:options option "reverse_printing")
              gs reverse_printing := true
            if (ink search ":" -1)<>(-1) and (gc:ink:options
              gs deaden := gc:ink deaden
          inks := remain
        if gs:multiple_transparency 
          gs transparency := dim
        gs dimension := dim
        gs pixel_size := gs:dimension+gs:transparency
        var Str opt := options+" "+color_database:data:devic
        if (opt option "composed")
          each ch color_database:data:device:device:channel 
            if (keyof:ch search "+" -1)<>(-1)
              if (gs add_component device+":" keyof:ch)=succ
                gs composed := true
        var Str measure := options option "measure" Str devi
        (var Stream s) open "data:/pliant/graphic/gamut/"+me
        if s=success
          gs:component size += 1
          var Pointer:ColorComponent c :> gs:component gs:co
          var Int count := 0
          c:indice size := 0
          var (Array Array:Float) grid
          while not s:atend and { var Str l := s readline ; 
            if (l parse word:"ink" (var Str inkname) any:(va
              grid size += 1
              while (values parse (var Float f) any:(var Str
                grid grid:size-1 += f
                values := remain
              c indice += undefined
              for (var Int i) 0 gs:dimension-1
                if gs:component:i:name=inkname
                  c:indice c:indice:size-1 := i
              if (c:indice c:indice:size-1)<>undefined
                count += 1
          if count>=2
            c curve :> new Curven
            c:curve resize ColorSpectrum32:size\Float32:size
            var ColorSpectrum32 w32 := var ColorSpectrum32 undefined_spectrum
            while not s:atend
              var Str l := s readline
              if (l parse any:(var Str all) ":" (var ColorSp
                (var Array:Float params) size := grid size
                for (var Int i) 0 params:size-1
                  if (all parse params:i any:(var Str remain
                    all := remain
                  else
                    error error_id_corrupted "Incorrect line
            while not s:atend
              var Str l := s readline
              if (l parse any:(var Str all) ":" (var ColorSp
                (var Array:Float params) size := grid size
                for (var Int i) 0 params:size-1
                  if (all parse params:i any:(var Str remain
                    all := remain
                  else
                    error error_id_corrupted "Incorrect line
                var ColorSpectrum32 cs32 := cs
                if w32=undefined
                  w32 := cs
                var ColorSpectrum32 cs32 := cs/w32
                (var Array:Float point) size := ColorSpectru
                for (var Int i) 0 point:size-1
                  point i := addressof:cs32 map Float32 i
                (var Array:Float point) size := ColorSpectru
                for (var Int i) 0 point:size-1
                  point i := addressof:cs32 map Float32 i
                  if logarithm_grid
                    point i := log point:i
                c:curve define params point
            gs composed := true
          else
            gs:component size -= 1
        gs status := shunt gs:pixel_size<=gamut_maximum_dime
    plugin extra_gamuts
    if g:status=success
      cache_ready ((addressof Link:ColorGamut g) map Link:Ca
    else
      cache_cancel ((addressof Link:ColorGamut g) map Link:C
      var ExtendedStatus status := g status
      g :> new ColorGamut
      g status := status


#-----------------------------------------------------------
                c:curve define params point
            gs composed := true
          else
            gs:component size -= 1
        gs status := shunt gs:pixel_size<=gamut_maximum_dime
    plugin extra_gamuts
    if g:status=success
      cache_ready ((addressof Link:ColorGamut g) map Link:Ca
    else
      cache_cancel ((addressof Link:ColorGamut g) map Link:C
      var ExtendedStatus status := g status
      g :> new ColorGamut
      g status := status


#-----------------------------------------------------------
#   grid based conversion


constant grid_conversion_release 11
constant grid_conversion_cache 16


type ColorGridConversion
  inherit CachePrototype
  field Array:Float32 mapping
  field Int dim
  field Int steps
  field Int done
  field Str key

CachePrototype maybe ColorGridConversion


method conv compute src_gamut dest_gamut steps cached
  arg_w ColorGridConversion conv ; oarg ColorGamut src_gamut
  var Int dim := src_gamut dimension
  conv dim := dim
  conv steps := steps
  conv:mapping size := steps^dim*dest_gamut:dimension
  for (var Int i) 0 steps^dim-1
    conv:mapping i*dest_gamut:dimension := undefined
  conv done := 0
  if cached
    conv key := string_md5_hexa_signature (string src_gamut:
  (var Stream s) open "data:/pliant/graphic/cache/"+conv:key
  if s=success
    while s:readline<>""
      void
    s raw_read (addressof conv:mapping:0) conv:mapping:size*
    if s=success
      for (var Int i) 0 steps^dim-1
        if (conv:mapping i*dest_gamut:dimension)=defined
          conv:done += 1
    else
      for (var Int i) 0 steps^dim-1
        conv:mapping i*dest_gamut:dimension := undefined

method conv compute_node index src_gamut dest_gamut
  arg_rw ColorGridConversion conv ; arg Int index ; oarg Col
  var Str options := dest_gamut query "options"
  var Pointer:Float32 p :> conv:mapping index*dest_gamut:dim
  var ColorBuffer src_pixel dest_pixel
  for (var Int d) 0 conv:dim-1
    src_pixel:bytes d := (index\conv:steps^d)%conv:steps*255
  var ColorXYZ color := src_gamut simulate addressof:src_pix
  color_adjust color options
  dest_gamut formulate color addressof:dest_pixel
  dest_gamut decode addressof:dest_pixel (var (Array Float32
  for (var Int d) dest_gamut:dimension-1 0 step -1
    addressof:p map Float32 d := components d
  conv done += 1

method conv compute_node2 index src_gamut dest_gamut
  arg_rw ColorGridConversion conv ; arg Int index ; oarg Col
  part compute "compute lazy color conversion grid node "+(s
    conv compute_node index src_gamut dest_gamut
  if conv:key<>""
    if conv:done%256=0 or conv:done=conv:steps^conv:dim
      (var Stream s) open "data:/pliant/graphic/cache/"+conv
      s writeline "Pliant color conversion"
      s writeline "source_gamut "+(string src_gamut:name)
      s writeline "source_options "+string:(src_gamut query 
      s writeline "destination_gamut "+(string dest_gamut:na
      s writeline "destination_options "+string:(dest_gamut 
      s writeline "steps "+(string conv:steps)
      s writeline "release "+string:grid_conversion_release
      s writeline ""
      s raw_write (addressof conv:mapping:0) conv:mapping:si
      s close
      console "."

method conv apply src_pixel src_gamut dest_pixel dest_gamut
  arg_rw ColorGridConversion conv ; arg Address src_pixel ; 
  var Int dim := conv dim ; var Int steps := conv steps
  var Int base := 0  
  var Int n := 0
  var (Array Int gamut_maximum_dimension) gs # grid step
  var (Array Float gamut_maximum_dimension) remain
  check src_gamut:pixel_size=src_gamut:dimension
  var Int unit := 1
  for (var Int d) 0 src_gamut:dimension-1
    var Int v := src_pixel map uInt8 d
    if v=0
      void
    eif v=255
      base += (steps-1)*unit
    else
      var Int i := min v*(steps-1)\255 steps-2
      gs n := unit
      base += i*unit
      remain n := ( v - i*255\(steps-1) ) / ( (i+1)*255\(ste
      n += 1
    unit *= steps
  var (Array Float32 gamut_maximum_dimension) result
  for (var Int d) 0 dest_gamut:dimension-1
    result d := 0
  for (var Int u) 0 2^n-1
    var Int index := base ; var Float f := 1
    for (var Int d) 0 n-1
      if (u .and. 2^d)<>0
        index += gs d
        f *= remain d
      else
        f *= 1-remain:d
    var Pointer:Float32 p :> conv:mapping index*dest_gamut:d
    if p=undefined
      conv compute_node2 index src_gamut dest_gamut
    for (var Int d) 0 dest_gamut:dimension-1
      result d += f*p
      p :> addressof:p map Float32 1
  dest_gamut encode result dest_pixel


function color_grid_conversion src_gamut dest_gamut steps ca
  oarg ColorGamut src_gamut dest_gamut ; arg Int steps ; arg
  var Str k := (string src_gamut:name)+" "+string:(src_gamut
  if (cache_open "/pliant/color/grid/"+k ColorGridConversion
    var Int dim := src_gamut:dimension
    conv compute src_gamut dest_gamut (shunt steps=defined s
    cache_ready ((addressof Link:ColorGridConversion conv) m


#-----------------------------------------------------------
#   many components conversions



#   many components conversions



gvar Sem fast_simulation_sem

method g speedup src_gamut options -> speedup
  oarg ColorGamutSubstractive g ; oarg ColorGamut src_gamut 
  var Data:ColorDevice device
  if (entry_type addressof:src_gamut)=ColorGamutSubstractive
    device :> color_database:data:device (addressof:src_gamu
  if (entry_type addressof:src_gamut)=ColorGamutSubstractive
    var (Link Array:Int) mapping :> new Array:Int
    for (var Int i) 0 src_g:dimension-1
      part map_component
        for (var Int j) 0 g:dimension-1
          if src_g:component:i:name=g:component:j:name
            mapping += i ; mapping += j
            leave map_component
    speedup := addressof mapping
method g speedup src_gamut options -> speedup
  oarg ColorGamutSubstractive g ; oarg ColorGamut src_gamut 
  var Data:ColorDevice device
  if (entry_type addressof:src_gamut)=ColorGamutSubstractive
    device :> color_database:data:device (addressof:src_gamu
  if (entry_type addressof:src_gamut)=ColorGamutSubstractive
    var (Link Array:Int) mapping :> new Array:Int
    for (var Int i) 0 src_g:dimension-1
      part map_component
        for (var Int j) 0 g:dimension-1
          if src_g:component:i:name=g:component:j:name
            mapping += i ; mapping += j
            leave map_component
    speedup := addressof mapping
  eif device:grid:size>0
    var Link:ColorSplitConversion sconv :> color_split_conve
    speedup := addressof sconv
  else
  else
    var Link:ColorGridConversion gconv :> color_grid_convers
    if hash_rgb
      var Link:ColorSplitConversion sconv :> color_split_con
    fast_simulation_sem request
    if (options option "hurry") and not (exists g:fast_simulation) and g:dimension<=4
      (addressof:g omap ColorGamutSubstractive) another_gamut :> color_gamut g:name g:options+" another"
      (addressof:g omap ColorGamutSubstractive) xyz_gamut :> color_gamut "XYZ"
      (addressof:g omap ColorGamutSubstractive) fast_simulation :> color_grid_conversion g:another_gamut g:xyz_gamut (options option "hurry" Int 33) false
    fast_simulation_sem release
    if device:grid:size>0
      var Link:ColorSplitConversion sconv :> color_split_conversion src_gamut g device (null map ColorGridConversion) options
      speedup := addressof sconv
    else
      speedup := addressof sconv
    else
      speedup := addressof gconv
      var Link:ColorGridConversion gconv :> color_grid_conversion src_gamut g (options option "grid_steps" Int) true
      if hash_rgb
        var Link:ColorSplitConversion sconv :> color_split_conversion src_gamut g device gconv options
        speedup := addressof sconv
      else
        speedup := addressof gconv


export color_gamut_compute color_gamut_profile


export color_gamut_compute color_gamut_profile