Patch title: Release 92 bulk changes
Abstract:
File: /graphic/color/gamut.pli
Key:
    Removed line
    Added line
abstract
  ['ColorGamut' data type is defining how a pixel is encoded, I mean the meaning of various bits.]

# Copyright  Hubert Tonneau  hubert.tonneau@pliant.cx
# Copyright  Heliogroup
#
# This program is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License version 2
# as published by the Free Software Foundation.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# version 2 along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.


module "/pliant/language/compiler.pli"
module "/pliant/language/context.pli"
module "/pliant/language/os.pli"
module "/pliant/language/compiler/type/inherit.pli"
module "/pliant/math/functions.pli"
module "/pliant/math/curven.pli"
module "color.pli"
module "ink.pli"
module "gradation.pli"
module "spectrum.pli"
module "/pliant/graphic/misc/int.pli"
module "/pliant/graphic/misc/float.pli"
module "/pliant/graphic/misc/bytes.pli"
module "/pliant/language/stream.pli"
module "/pliant/admin/md5.pli"
module "database.pli"
module "adjust.pli"
module "/pliant/language/data/cache.pli"

constant hash_conversion true
constant hash_rgb true
constant screen_option false


#-------------------------------------------------------------------------
#   prototype


public

  constant color_gamut_additive 1
  constant color_gamut_substractive 2
  constant gamut_maximum_dimension 32
  
  type ColorBuffer
    field (Array uInt8 gamut_maximum_dimension) bytes

  type ColorGamut
    inherit CachePrototype
    field Int pixel_size
    field Int dimension
    field Int transparency <- 0
    field Int padding <- 0
    field Int bits_per_component <- 8
    field Str name
    field Int model <- 0
    field ExtendedStatus status <- failure

  CachePrototype maybe ColorGamut
  
  method p drop # avoid clashing with CachePrototype
    oarg_rw ColorGamut p
    generic

  method g decode pixel components
    oarg ColorGamut g ; arg Address pixel ; arg_w (Array Float32 gamut_maximum_dimension) components
    generic

  method g encode components pixel
    oarg ColorGamut g ; arg (Array Float32 gamut_maximum_dimension) components ; arg Address pixel
    generic

  method g opacity_decode pixel opacity
    oarg ColorGamut g ; arg Address pixel ; arg_w (Array Float32 gamut_maximum_dimension) opacity
    generic
    if g:transparency=0
      for (var Int i) 0 g:dimension-1
        opacity i := 1
    eif g:transparency=1
      for (var Int i) 0 g:dimension-1
        opacity i := (pixel map uInt8 g:dimension)/255
    eif g:transparency=g:dimension
      for (var Int i) 0 g:dimension-1
        opacity i := (pixel map uInt8 g:dimension+i)/255
    else
      error "Inconsistent transparency in gamut "+g:name

  method g opacity_encode opacity pixel
    oarg ColorGamut g ; arg (Array Float32 gamut_maximum_dimension) opacity ; arg Address pixel
    generic
    if g:transparency=1
      pixel map uInt8 g:dimension := bound (cast opacity:0*255 Int) 0 255
    eif g:transparency=g:dimension
      for (var Int i) 0 g:dimension-1
        pixel map uInt8 g:dimension+i := bound (cast opacity:i*255 Int) 0 255

  method g simulate pixel -> color
    oarg ColorGamut g ; arg Address pixel ; arg ColorXYZ color
    generic

  method g simulate2 pixel -> filter
    oarg ColorGamut g ; arg Address pixel ; arg ColorSpectrum32 filter
    generic
    filter := var ColorSpectrum empty_spectrum

  method g formulate color options pixel
    oarg ColorGamut g ; arg ColorXYZ color ; arg Str options ; arg Address pixel
    generic

  method g formulate color pixel
    oarg ColorGamut g ; arg ColorXYZ color ; arg Address pixel
    g formulate color "" pixel

  method g speedup src_gamut options -> speedup
    oarg ColorGamut g src_gamut ; arg Str options ; arg Arrow speedup
    generic
    speedup := null

  method g query question -> answer
    oarg ColorGamut g ; arg Str question answer
    generic
    answer := ""

  method g configure parameter value -> status
    oarg_rw ColorGamut g ; arg Str parameter value ; arg ExtendedStatus status
    generic
    status := failure "unsupported"

  function 'cast ExtendedStatus' g -> status
    arg ColorGamut g; arg ExtendedStatus status
    extension
    status := g status


function transparency_convert src_pixels src_gamut dest_pixels dest_gamut count
  arg Address src_pixels dest_pixels ; oarg ColorGamut src_gamut dest_gamut ; arg Int count
  if dest_gamut:transparency=0
    return
  var Address src := src_pixels translate Byte src_gamut:dimension ; var Int src_psize := src_gamut pixel_size
  var Address dest := dest_pixels translate Byte dest_gamut:dimension ; var Int dest_psize := dest_gamut pixel_size
  var Address stop := dest translate Byte count*dest_psize
  if src_gamut:transparency=0
    while dest<>stop
      dest map uInt8 := 255
      dest := dest translate Byte dest_psize    
  eif src_gamut:transparency=1
    while dest<>stop
      dest map uInt8 := src map uInt8
      src := src translate Byte src_psize ; dest := dest translate Byte dest_psize
  else
    var Int last := src_gamut:transparency-1
    while dest<>stop
      var Int opacity := 0
      for (var Int i) 0 last
        opacity := max opacity (src map uInt8 i)
      dest map uInt8 := opacity
      src := src translate Byte src_psize ; dest := dest translate Byte dest_psize
  if dest_gamut:transparency>1
    var Address dest := dest_pixels translate Byte dest_gamut:dimension
    var Address stop := dest translate Byte count*dest_psize
    var Int last := dest_gamut:transparency-1
    while dest<>stop
      var Int opacity := dest map uInt8
      for (var Int i) 1 last
        dest map uInt8 i := opacity
      dest := dest translate Byte dest_psize    

function default_convert src_pixels src_gamut dest_pixels dest_gamut count
  arg Address src_pixels dest_pixels ; oarg ColorGamut src_gamut dest_gamut ; arg Int count
  var Str options := dest_gamut query "options"
  var Address s := src_pixels ; var Int src_psize := src_gamut pixel_size
  var Address stop := src_pixels translate Byte count*src_psize
  var Address d := dest_pixels ; var Int dest_psize := dest_gamut pixel_size
  while s<>stop
    if s<>src_pixels and not (memory_different s src_psize (s translate Byte -src_psize) src_psize)
      memory_copy (d translate Byte -dest_psize) d dest_psize
    else
      var ColorXYZ color := src_gamut simulate s
      color_adjust color options
      dest_gamut formulate color d
    s := s translate Byte src_psize ; d := d translate Byte dest_psize
  transparency_convert src_pixels src_gamut dest_pixels dest_gamut count

method dest_gamut convert src_gamut src_pixels dest_pixels count speedup
  oarg ColorGamut dest_gamut src_gamut ; arg Address src_pixels dest_pixels ; arg Int count ; arg Address speedup
  generic
  default_convert src_pixels src_gamut dest_pixels dest_gamut count

export '. convert'


#-------------------------------------------------------------------------
#   additive (RGB)


type ColorGamutRGB
  inherit ColorGamut
  field CBool reversed
  field Str options
  
ColorGamut maybe ColorGamutRGB


method g decode pixel components
  oarg ColorGamutRGB g ; arg Address pixel ; arg_w (Array Float32 gamut_maximum_dimension) components
  addressof:components map ColorRGB := pixel map ColorRGB888

method g encode components pixel
  oarg ColorGamutRGB g ; arg (Array Float32 gamut_maximum_dimension) components ; arg Address pixel
  pixel map ColorRGB888 := addressof:components map ColorRGB
  
method g query question -> answer
  oarg ColorGamutRGB g ; arg Str question answer
  if question="options"
    answer := g options
  else
    answer := ""

method g configure parameter value -> status
  oarg_rw ColorGamutRGB g ; arg Str parameter value ; arg ExtendedStatus status
  if parameter="options"
    g options := value
  else
    status := failure "unsupported"

method g simulate pixel -> color
  oarg ColorGamutRGB g ; arg Address pixel ; arg ColorXYZ color
  var Address rgb
  if g:reversed
    rgb := addressof (var Int32 buffer)
    for (var Int c) 0 2
      rgb map uInt8 c := pixel map uInt8 2-c
  else
    rgb := pixel
  color := cast (rgb map ColorRGB888) ColorXYZ


method g formulate color options pixel
  oarg ColorGamutRGB g ; arg ColorXYZ color ; arg Str options ; arg Address pixel
  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


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


constant white_mapping true


type ColorComponent
  field Link:ColorInk ink
  field Link:Curven curve
  field Str name
  field Array:Int indice ; field uInt mask

type ColorGamutSubstractive
  inherit ColorGamut
  field Array:ColorComponent component
  field Str device options
  field Float specular <- 0
  field Float deaden <- 0
  if screen_option
    field CBool screen <- false
  field CBool composed <- false
  field CBool multiple_transparency <- false
  field CBool no_opacity <- false
  field CBool reverse_printing <- false
  field Int negatives <- 0
  
ColorGamut maybe ColorGamutSubstractive


method g decode pixel components
  oarg ColorGamutSubstractive g ; arg Address pixel ; arg_w (Array Float32 gamut_maximum_dimension) components
  for (var Int i) 0 g:dimension-1
    components i := g:component:i:ink:gradation decode (pixel map uInt8 i)

method g encode components pixel
  oarg ColorGamutSubstractive g ; arg (Array Float32 gamut_maximum_dimension) components ; arg Address pixel
  for (var Int i) 0 g:dimension-1
    pixel map uInt8 i := g:component:i:ink:gradation encode components:i

method gamut apply_opacity src dest
  arg ColorGamutSubstractive gamut ; arg Address src dest
  memory_copy src dest gamut:pixel_size
  if gamut:reverse_printing
    for (var Int i) gamut:dimension-1 0 step -1
      var Pointer:ColorInk ink :> gamut:component:i ink
      if ink:opacity=defined and ink:opacity>0
        var Float d := ink:gradation decode (dest map uInt8 i)
        if d>0
          var Float f := 1-ink:opacity*d
          for (var Int j) i+1 gamut:dimension-1
            var Pointer:uInt8 p :> dest map uInt8 j
            var Pointer:ColorGradation g :> gamut:component:j:ink gradation
            p := g encode (g decode p)*f
  else
    for (var Int i) 0 gamut:dimension-1
      var Pointer:ColorInk ink :> gamut:component:i ink
      if ink:opacity=defined and ink:opacity>0
        var Float d := ink:gradation decode (dest map uInt8 i)
        if d>0
          var Float f := 1-ink:opacity*d
          for (var Int j) 0 i-1
            var Pointer:uInt8 p :> dest map uInt8 j
            var Pointer:ColorGradation g :> gamut:component:j:ink gradation
            p := g encode (g decode p)*f

method gamut dispatch_pixel pixel plus minus
  arg ColorGamutSubstractive gamut ; arg Address pixel plus minus
  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
    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
    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 j) Int) (cast (plus map uInt8 i) Int)
  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
    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 j) Int) (cast (plus map uInt8 i) Int)
  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 ColorSpectrum32 f
  (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

method gamut simulate2 pixel -> filter
  oarg ColorGamutSubstractive gamut ; arg Address pixel ; arg ColorSpectrum32 filter
  part simulate "substractive color simulation "+gamut:name
    var ColorBuffer pixel2
    if gamut:no_opacity
      memory_copy pixel addressof:pixel2 gamut:pixel_size
    else
      gamut apply_opacity pixel addressof:pixel2
    if white_mapping
      filter := cast 1 ColorSpectrum32
    filter := cast 0 ColorSpectrum32
    var ColorBuffer plus_buffer minus_buffer
    var Address plus minus
    if gamut:component:size<=gamut_maximum_dimension
      plus := addressof plus_buffer ; minus := addressof minus_buffer
    else
      var Pointer:ColorSpectrum32 s0 :> gamut:component:0:ink:s0
      var Float Y0 := illuminant_spectrum*s0 Y
      filter := (1/Y0)*s0
    if screen_option and gamut:screen
      var (Array Int gamut_maximum_dimension) dim
      var (Array Float gamut_maximum_dimension) dens
      var Int n := 0
      for (var Int d) 0 gamut:dimension-1
        var Int v := addressof:pixel2 map uInt8 d
        var Pointer:ColorComponent c :> gamut:component d
        if v=0
          filter *= c:ink f0
        eif v=255
          filter *= c:ink f100
      plus := memory_allocate gamut:component:size null ; minus := memory_allocate gamut:component:size null
    gamut dispatch_pixel addressof:pixel2 plus minus
    var ColorSpectrum32 strongest := cast 1 ColorSpectrum32
    var Int negatives := gamut negatives
    for (var Int i) 0 gamut:component:size-1
      var Int p := plus map uInt8 i
      var Int m := minus map uInt8 i
      var CBool positive := (negatives .and. 2^i)=0
      if (shunt positive p>m p<>255)
        var Pointer:ColorComponent c :> gamut:component i
        var Pointer:ColorInk ink :> c ink
        if (exists c:curve)
          filter += exposure (-1)*log:(curven_simulation c pixel) (-gamut:deaden)
        eif ink:deaden=gamut:deaden
          filter += ink:deaden_filter:p
          if m>0
            check positive
            filter += (-1)*ink:deaden_filter:m
        else
          dim n := d
          dens n := c:ink:gradation:decode_table v
          n += 1
      var ColorSpectrum32 sum := cast 0 ColorSpectrum32
      for (var Int u) 0 3^n-1
        var Float w := 1 ; var ColorSpectrum32 f := filter
        for (var Int d) 0 n-1
          var Pointer:ColorComponent c :> gamut:component dim:d
          var Int r := u \ 3^d % 3
          if r=0
            w *= (1-dens:d)*(1-dens:d) ; f *= c:ink f0
          eif r=1
            w *= 2*dens:d*(1-dens:d) ; f *= c:ink f50
          else
            w *= dens:d*dens:d ; f *= c:ink f100
        sum += w*f
      filter := sum
    else
      var ColorBuffer plus_buffer minus_buffer
      var Address plus minus
      if gamut:component:size<=gamut_maximum_dimension
        plus := addressof plus_buffer ; minus := addressof minus_buffer
      else
        plus := memory_allocate gamut:component:size null ; minus := memory_allocate gamut:component:size null
      gamut dispatch_pixel addressof:pixel2 plus minus
      var CBool has_deaden := gamut:deaden>0
      if has_deaden
        var ColorSpectrum32 strongest := cast 1 ColorSpectrum32
      var Int negatives := gamut negatives
      for (var Int i) 0 gamut:component:size-1
        var Int p := plus map uInt8 i
        var Int m := minus map uInt8 i
        var CBool positive := (negatives .and. 2^i)=0
        if (shunt positive p>m p<>255)
          var Pointer:ColorComponent c :> gamut:component:i
          if m=0
            filter *= c:ink:filter p
            if has_deaden
              strongest := min strongest c:ink:filter:p
          eif has_deaden
          filter += exposure (-1)*(log ink:filter:p) (-gamut:deaden)
          if m>0
            check positive
            var ColorSpectrum32 fi := (c:ink:filter p)/(c:ink:filter m)
            filter *= fi
            strongest := min strongest fi
          else
            check positive
            filter := filter*(c:ink:filter p)/(c:ink:filter m)
      if has_deaden
        filter := strongest*(filter/strongest)^(1/(1+gamut:deaden))
      if gamut:component:size>gamut_maximum_dimension
        memory_free plus ; memory_free minus
    if gamut:specular>0
      filter := (1-gamut:specular)*filter+(cast gamut:specular ColorSpectrum32)
            filter += (-1)*(exposure (-1)*(log ink:filter:m) (-gamut:deaden))
    filter := exp (-1)*(unexposure filter (-gamut:deaden))
    if gamut:component:size>gamut_maximum_dimension
      memory_free plus ; memory_free minus

method gamut simulate pixel -> color
  oarg ColorGamutSubstractive gamut ; arg Address pixel ; arg ColorXYZ color
  color := filter_XYZ (gamut simulate2 pixel)
  color_adjust color (gamut:options option "gamut_adjust" Str)


method gamut try_formulate wished pixel using l c -> distance
  oarg ColorGamut gamut ; arg ColorXYZ wished ; arg Address pixel ; arg Array:Int using ; arg Float l c ; arg Float distance
  (var Array:Int maximum) size := gamut dimension
  for (var Int dim) 0 gamut:dimension-1
    if not ((gamut query "component_maximum "+string:dim) parse maximum:dim)
      maximum dim := 255
  var Int limit
  var Float flimit := (gamut query "options") option "limit" Float
  if flimit=defined
    limit := cast flimit*255 Int
  else
    limit := undefined
  var Int dimension := using size
  distance := cmc_distance wished (gamut simulate pixel) l c
  var Int step := 4 ; var CBool again := true
  while step>0
    again := false
    memory_copy pixel addressof:(var ColorBuffer pixel2) gamut:pixel_size
    for (var Int i) 0 3^dimension-1
      part try_one
        memory_copy pixel addressof:(var ColorBuffer pixel1) gamut:pixel_size
        var Int ii := i
        for (var Int dim) 0 dimension-1
          var Int d := using dim
          var Int delta := ii%3-1 ; ii \= 3
          if delta<0
            if pixel1:bytes:d<step
              leave try_one
            pixel1:bytes d -= step
          eif delta>0
            if pixel1:bytes:d+step>maximum:d
              leave try_one
            pixel1:bytes d += step
        if limit=defined
          var Int total := 0
          for (var Int d) 0 gamut:dimension-1
            total += pixel1:bytes d
          if total>limit
            leave try_one
        var Float dist1 := cmc_distance wished (gamut simulate addressof:pixel1) l c
        if dist1<distance
          memory_copy addressof:pixel1 addressof:pixel2 gamut:pixel_size ; distance := dist1
          again := true
    memory_copy addressof:pixel2 pixel gamut:pixel_size
    if not again
      step -= 1 ; again := true

method gamut fill_pixel pixel
  oarg ColorGamutSubstractive gamut ; arg Address pixel
  memory_clear pixel gamut:pixel_size
  for (var Int i) 0 gamut:dimension-1
    var Str ink := gamut query "component_name "+string:i
    if (gamut:options option "initial_"+ink)
      pixel map uInt8 i := cast (gamut:options option "initial_"+ink Float)*255 Int

method gamut formulate color options pixel
  oarg ColorGamutSubstractive gamut ; arg ColorXYZ color ; arg Str options ; arg Address pixel
  var Str opt := options+" "+(gamut query "options")
  if not ((opt (options option_position "removal" 0) options:len) parse word:"removal" (var Int b0) (var Int b1) any)
    b0 := 0 ; b1 := 0
  var Float epsilon := opt option "epsilon" Float 0.5
  var Float l := opt option "l" Float cmc_distance_l_parameter
  var Float c := opt option "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:s100/gamut:component:i:ink:s0) Y
        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) gamut:pixel_size
          var Float d := gamut try_formulate color addressof:test using l c
          if d<distance
            memory_copy addressof:test pixel gamut:pixel_size ; distance := d
    if (options 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:bytes 3 := 255
      var Float d := gamut try_formulate color addressof:test using l c
      if d<distance
        memory_copy addressof:test pixel gamut:pixel_size ; distance := d
      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 := black
      using 0 := 0 ; using 1 := 1 ; using 2 := 2
      d := gamut try_formulate color addressof:test using l c
      if d<distance or d<epsilon
        memory_copy addressof:test pixel gamut:pixel_size ; distance := d
  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


method g query question -> answer
  oarg ColorGamutSubstractive g ; arg Str question answer
  if (question parse word:"component_name" (var Int i)) and i>=0 and i<g:component:size
    answer := g:component:i name
  eif (question parse word:"component_maximum" (var Int i)) and i>=0 and i<g:component:size
    answer := string g:component:i:ink:maximum
  eif (question parse word:"component_options" (var Int i)) and i>=0 and i<g:component:size
    answer := g:component:i:ink options
  eif question="options"
    answer := g options
  eif question="signature"
    answer := g:options+(shunt g:no_opacity " no_opacity" "")
    for (var Int i) 0 g:dimension-1
      answer += " "+(string g:component:i:name)+" "+(string g:component:i:ink:options)
  else
    answer := ""


method g add_component device inks
  arg_rw ColorGamutSubstractive g ; arg Str device inks
method g add_component device inks -> status
  arg_rw ColorGamutSubstractive g ; arg Str device inks ; arg Status status
  g:component size += 1
  var Pointer:ColorComponent c :> g:component g:component:size-1
  c mask := 0
  var Str all := inks ; c:indice size := 0
  while all<>""
    if not (all parse any:(var Str ink) "+" any:(var Str remain))
      ink := all ; remain := ""
    part search_component
      for (var Int i) 0 g:dimension-1
        if g:component:i:name=ink
          c mask := c:mask .or. g:component:i:mask
          c indice += i
          leave search_component
      g:component size -= 1
      return
      return failure
    all := remain
  if c:indice:size<2
    g:component size -= 1
    return
    return failure
  c ink :> color_ink device+inks
  c name := inks
  status := success


#-------------------------------------------------------------------------
#   building a gamut from name using colors database


function rgb_gamut g name transparency padding reversed options
  arg_rw ColorGamutRGB g ; arg Str name ; arg Int transparency padding ; arg CBool reversed ; arg Str options
  g name := name
  g pixel_size := 3+transparency+padding
  g dimension := 3
  g transparency := transparency
  g padding := padding
  g model := color_gamut_additive
  g reversed := reversed
  g status := success
  g options := options

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
  else
    t :> ColorGamutRGB
  plugin extra_types
  if (cache_open "/pliant/color/gamut/"+string:name+options t ((addressof Link:ColorGamut g) map Link:CachePrototype))
    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 ColorGamutRGB
        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=ColorGamutSubstractive
        var Pointer:ColorGamutSubstractive gs :> addressof:g map ColorGamutSubstractive
        gs model := color_gamut_substractive
        gs device := device
        gs options := color_database:data:device:device options
        gs deaden := gs:options option "deaden" Float 0
        gs no_opacity := options option "no_opacity"
        inks := replace inks "cmyk" "process_cyan+process_magenta+process_yellow+process_black" ; var Int dim := 0
        while inks<>""
          if not (inks parse 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 dim
            gc name := ink
            if (ink parse any:(var Str base) "#" any)
              ink := base
            gc ink :> color_ink (shunt (ink search ":" -1)=(-1) device+":"+ink ink) options
            if gc:ink=failure
              g status := failure (shunt (exists color_database:data:device:device:channel:ink) "Bad" "Unknown")+" '"+ink+"' ink"
              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 option "deaden")
              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:device:device:options
        if (opt option "composed")
          each ch color_database:data:device:device:channel # SLOW !
            if (keyof:ch search "+" -1)<>(-1)
              gs add_component device+":" keyof:ch
        gs device := device
        gs options := color_database:data:device:device options
        gs specular := gs:options option "final_specular" Float (gs:options option "specular" Float 0)
        gs deaden := gs:options option "deaden" Float 0
        if screen_option
          gs screen := gs:options option "screen"
        gs no_opacity := options option "no_opacity"
        gs status := success
              if (gs add_component device+":" keyof:ch)=success
                gs composed := true
        var Str measure := options option "measure" Str device
        (var Stream s) open "data:/pliant/graphic/gamut/"+measure in+safe
        if s=success
          gs:component size += 1
          var Pointer:ColorComponent c :> gs:component gs:component:size-1
          var Int count := 0
          c:indice size := 0
          var (Array Array:Float) grid
          while not s:atend and { var Str l := s readline ; l<>"" }
            if (l parse word:"ink" (var Str inkname) any:(var Str values))
              grid size += 1
              while (values parse (var Float f) any:(var Str remain))
                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 grid:size grid
            while not s:atend
              var Str l := s readline
              if (l parse any:(var Str all) ":" (var ColorSpectrum cs) )
                (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 in gamut measures files "+s:name+" ("+l+")"
                var ColorSpectrum32 cs32 := cs
                (var Array:Float point) size := ColorSpectrum32:size\Float32:size
                for (var Int i) 0 point:size-1
                  point i := addressof:cs32 map Float32 i
                c:curve define params point
            gs composed := true
          else
            gs:component size -= 1
        gs status := shunt gs:pixel_size<=gamut_maximum_dimension success failure:"Too many components"
    plugin extra_gamuts
    if g:status=success
      cache_ready ((addressof Link:ColorGamut g) map Link:CachePrototype)
    else
      cache_cancel ((addressof Link:ColorGamut g) map Link:CachePrototype)
      var ExtendedStatus status := g status
      g :> new ColorGamut
      g status := status

function color_gamut name -> g
  arg Str name ; arg Link:ColorGamut g
  g :> color_gamut name ""

export color_gamut


#-------------------------------------------------------------------------
#   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
  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%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
      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)


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


type ColorPartConversion
  field Array:Int mapping
  field Link:ColorGamut gamut
  field Link:ColorGridConversion grid

type ColorSplitConversion
  field Array:ColorPartConversion part
  field CBool single <- false
  field CBool opacity <- false
  field Float limit
  if hash_conversion
    field Address cache_buffer <- null
    field uInt cache_size

if hash_conversion
  function destroy conv
    arg_w ColorSplitConversion conv
    memory_free conv:cache_buffer
  

function color_split_conversion src_gamut dest_gamut device grid options -> conv
  oarg ColorGamut src_gamut dest_gamut ; arg Data:ColorDevice device ; arg ColorGridConversion grid ; arg Str options ; arg Link:ColorSplitConversion conv
  conv :> new ColorSplitConversion
  if exists:grid
    var ColorPartConversion part
    part grid :> grid
    conv part += part
    conv single := true
  else
    # check (entry_type addressof:src_gamut)=ColorGamutSubstractive
    for (var Int i) 0 src_gamut:dimension-1
      var Pointer:ColorInk ink1 :> (addressof:src_gamut map ColorGamutSubstractive):component:i ink
      if ink1:opacity=defined and ink1:opacity>0
        conv opacity := true
    var (Dictionary Str Int) component
    for (var Int i) 0 src_gamut:dimension-1
      component insert (src_gamut query "component_name "+string:i) i
    while component:size>0
      var Int best_count := 0 ; var Str best_grid ; var Int best_steps
      if (options option "grid" Str)<>""
        var Str all := options option "grid" Str ; var Int count := 0
        while all<>""
          if not (all parse any:(var Str ink) "+" any:(var Str remain))
            ink := all ; remain := ""
          if exists:(component first ink)
            count += 1
          all := remain
        best_count := count ; best_grid := options option "grid" Str ; best_steps := options option "grid_steps" Int undefined
      if best_count<2
        each g device:grid
          var Str all := keyof g ; var Int count := 0
          while all<>""
            if not (all parse any:(var Str ink) "+" any:(var Str remain))
              ink := all ; remain := ""
            if exists:(component first ink)
              count += 1
            all := remain
          if count>best_count
            best_count := count ; best_grid := keyof g ; best_steps := g
      if best_count>1
        var ColorPartConversion part
        part:mapping size := 0
        var Str all := best_grid
        while all<>""
          if not (all parse any:(var Str ink) "+" any:(var Str remain))
            ink := all ; remain := ""
          if exists:(component first ink)
            part mapping += component first ink
            component -= component first ink
          else
            part mapping += undefined
          all := remain
        part gamut :> color_gamut keyof:device+":"+best_grid "no_opacity"
        if part:gamut=failure
          console "Incorrect gamut " keyof:device+":"+best_grid eol
          conv :> null map ColorSplitConversion
          return
        part grid :> color_grid_conversion part:gamut dest_gamut best_steps true
        conv part += part
      else
        each comp component
          var ColorPartConversion part
          part:mapping size := 1
          part:mapping 0 := comp
          part gamut :> color_gamut keyof:device+":"+(component key comp) "no_opacity"
          if part:gamut=failure
            console "Incorrect gamut " keyof:device+":"+(component key comp) eol
            conv :> null map ColorSplitConversion
            return
          part grid :> color_grid_conversion part:gamut dest_gamut undefined true
          conv part += part
        component := var (Dictionary Str Int) empty_dict
  conv limit := (dest_gamut query "options") option "limit" Float
  if hash_conversion
    conv cache_size := options option "hash" Int 63541
    conv cache_buffer := memory_zallocate conv:cache_size*(uInt:size+src_gamut:pixel_size+dest_gamut:pixel_size) addressof:conv


method conv apply src_pixel src_gamut dest_pixel dest_gamut
  arg_rw ColorSplitConversion conv ; arg Address src_pixel ; oarg ColorGamut src_gamut ; arg Address dest_pixel ; oarg ColorGamut dest_gamut
  # check (entry_type addressof:src_gamut)=ColorGamutSubstractive
  if hash_conversion
    var Int src_psize := src_gamut pixel_size
    var Int dest_psize := dest_gamut pixel_size
    var uInt key := 0
    update_hash_key key src_pixel src_psize
    key %= conv cache_size
    var Pointer:uInt sem :> (conv:cache_buffer translate Byte key*(uInt:size+src_psize+dest_psize)) map uInt
    var Address ptr := addressof:sem translate uInt 1
    part aquire
      var uInt u := atomic_read_and_set sem 2
      if u=1 # cell is defined and not locked
        if not (memory_different ptr src_psize src_pixel src_psize)
          memory_copy (ptr translate Byte src_psize) dest_pixel dest_psize
          sem := 1
          return
        sem := 1
      eif u=0 # cell is not defined
        sem := 0
      else # u=2 : cell is locked
        os_yield
        restart aquire
  if conv:single
    conv:part:0:grid apply src_pixel src_gamut dest_pixel dest_gamut
  else
    var Address ptr0
    if conv:opacity
      (addressof:src_gamut map ColorGamutSubstractive) apply_opacity src_pixel addressof:(var ColorBuffer pixel0)
      ptr0 := addressof pixel0
    else
      ptr0 := src_pixel
    var (Array Float32 gamut_maximum_dimension) result
    for (var Int j) 0 dest_gamut:dimension-1
      result j := 0
    for (var Int i) 0 conv:part:size-1
      var Pointer:ColorPartConversion part :> conv:part i
      var ColorBuffer pixel1
      for (var Int j) 0 part:mapping:size-1
        if part:mapping:j=defined
          addressof:pixel1 map uInt8 j := ptr0 map uInt8 part:mapping:j
        else
          addressof:pixel1 map uInt8 j := 0
      var ColorBuffer pixel2
      conv:part:i:grid apply addressof:pixel1 part:gamut addressof:pixel2 dest_gamut
      dest_gamut decode addressof:pixel2 (var (Array Float32 gamut_maximum_dimension) f)
      for (var Int j) 0 dest_gamut:dimension-1
        result j += f:j*(1-result:j)
    if conv:limit=defined
      var Float total := 0
      for (var Int j) 0 dest_gamut:dimension-1
        total += result j
      if total>conv:limit
        var Float remove := (total-conv:limit)/(shunt dest_gamut:dimension>3 dest_gamut:dimension-1 dest_gamut:dimension)
        for (var Int j) 0 dest_gamut:dimension-1
          if j<>3 # leave black unmodified
            result j -= remove
    dest_gamut encode result dest_pixel
  if hash_conversion
    part lock
      var uInt u := atomic_read_and_set sem 2
      if u=2
        os_yield
        restart lock
    memory_copy src_pixel ptr src_psize
    memory_copy dest_pixel (ptr translate Byte src_psize) dest_psize
    sem := 1


#-------------------------------------------------------------------------
#   to additive advanced conversion


method g speedup src_gamut options -> speedup
  oarg ColorGamutRGB g src_gamut ; arg Str options ; arg Arrow speedup
  if (entry_type addressof:src_gamut)=ColorGamutSubstractive and (options option "fast")
    speedup := addressof void
  eif src_gamut:model=color_gamut_additive and g:options<>""
    var Link:ColorGridConversion gconv :> new ColorGridConversion
    gconv compute src_gamut g (min (max (g:options option "grid_steps" Int 17) 5) 65) false
    if hash_rgb
      var Link:ColorSplitConversion sconv :> color_split_conversion src_gamut g (var Data:ColorDevice device) gconv options
      speedup := addressof sconv
    else
      speedup := addressof gconv
  else
    speedup := null


method dest_gamut convert src_gamut src_pixels dest_pixels count speedup
  oarg ColorGamutRGB dest_gamut ; oarg ColorGamut src_gamut ; arg Address src_pixels dest_pixels ; arg Int count ; arg Address speedup
  if speedup<>null
    if entry_type:speedup=Void
      var Link:ColorGamutSubstractive g :> addressof:src_gamut map ColorGamutSubstractive
      var Address s := src_pixels ; var Address stop := src_pixels translate Byte count*g:pixel_size
      var Address d := dest_pixels
      while s<>stop
        (var ColorFast cf) init
        if g:reverse_printing
          for (var Int i) g:dimension-1 0 step -1
            cf apply g:component:i:ink (s map uInt8 i)
        else
          for (var Int i) 0 g:dimension-1
            cf apply g:component:i:ink (s map uInt8 i)
        cf terminate (d map ColorRGB888)
        s := s translate Byte g:pixel_size ; d := d translate Byte dest_gamut:pixel_size
      transparency_convert src_pixels src_gamut dest_pixels dest_gamut count
    eif entry_type:speedup=ColorGridConversion
      var Link:ColorGridConversion gconv :> speedup map ColorGridConversion
      var Address s := src_pixels ; var Int src_psize := src_gamut pixel_size
      var Address stop := src_pixels translate Byte count*src_psize
      var Address d := dest_pixels ; var Int dest_psize := dest_gamut pixel_size
      while s<>stop
        if s<>src_pixels and not (memory_different s src_psize (s translate Byte -src_psize) src_psize)
          memory_copy (d translate Byte -dest_psize) d dest_psize
        else
          gconv apply s src_gamut d dest_gamut
        s := s translate Byte src_psize ; d := d translate Byte dest_psize
      transparency_convert src_pixels src_gamut dest_pixels dest_gamut count
    eif entry_type:speedup=ColorSplitConversion
      var Link:ColorSplitConversion sconv :> speedup map ColorSplitConversion
      var Address s := src_pixels ; var Int src_psize := src_gamut pixel_size
      var Address stop := src_pixels translate Byte count*src_psize
      var Address d := dest_pixels ; var Int dest_psize := dest_gamut pixel_size
      while s<>stop
        if s<>src_pixels and not (memory_different s src_psize (s translate Byte -src_psize) src_psize)
          memory_copy (d translate Byte -dest_psize) d dest_psize
        else
          sconv apply s src_gamut d dest_gamut
        s := s translate Byte src_psize ; d := d translate Byte dest_psize
      transparency_convert src_pixels src_gamut dest_pixels dest_gamut count
  eif src_gamut:model=color_gamut_additive
    var CBool src_gamut_reversed := (addressof:src_gamut map ColorGamutRGB) reversed
    if dest_gamut:pixel_size=src_gamut:pixel_size and dest_gamut:reversed=src_gamut_reversed
      memory_copy src_pixels dest_pixels count*dest_gamut:pixel_size
    else
      if dest_gamut:pixel_size=1
        bytes_copy (src_pixels translate uInt8 src_gamut:dimension\2) src_gamut:pixel_size dest_pixels dest_gamut:pixel_size count
      eif src_gamut:pixel_size=1
        for (var Int c) 0 2
          bytes_copy src_pixels src_gamut:pixel_size (dest_pixels translate uInt8 c) dest_gamut:pixel_size count
      eif dest_gamut:reversed=src_gamut_reversed
        bytes_copy24 src_pixels src_gamut:pixel_size dest_pixels dest_gamut:pixel_size count
      else
        for (var Int c) 0 2
          bytes_copy (src_pixels translate uInt8 2-c) src_gamut:pixel_size (dest_pixels translate uInt8 c) dest_gamut:pixel_size count
      if dest_gamut:transparency=1 and src_gamut:transparency=1
        bytes_copy (src_pixels translate uInt8 src_gamut:dimension) src_gamut:pixel_size (dest_pixels translate uInt8 src_gamut:dimension) dest_gamut:pixel_size count
      eif dest_gamut:transparency=1
        bytes_fill (dest_pixels translate uInt8 dest_gamut:dimension) dest_gamut:pixel_size count
  else
    default_convert src_pixels src_gamut dest_pixels dest_gamut count


#-------------------------------------------------------------------------
#   to substractive advanced conversion


method g speedup src_gamut options -> speedup
  oarg ColorGamutSubstractive g ; oarg ColorGamut src_gamut ; arg Str options ; arg Arrow speedup
  var Data:ColorDevice device
  if (entry_type addressof:src_gamut)=ColorGamutSubstractive
    device :> color_database:data:device (addressof:src_gamut map ColorGamutSubstractive):device
  if (entry_type addressof:src_gamut)=ColorGamutSubstractive and { var Link:ColorGamutSubstractive src_g :> addressof:src_gamut map ColorGamutSubstractive ; src_g:device=g:device }
    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_conversion src_gamut g device (null map ColorGridConversion) options
    speedup := addressof sconv
  else
    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

method dest_gamut convert src_gamut src_pixels dest_pixels count speedup
  oarg ColorGamutSubstractive dest_gamut ; oarg ColorGamut src_gamut ; arg Address src_pixels dest_pixels ; arg Int count ; arg Address speedup
  if speedup<>null and entry_type:speedup=Array:Int
    memory_clear dest_pixels count*dest_gamut:pixel_size
    if src_gamut:transparency=1 and not (addressof:src_gamut map ColorGamutSubstractive):multiple_transparency
      transparency_convert src_pixels src_gamut dest_pixels dest_gamut count
    var (Pointer Array:Int) mapping :> speedup map Array:Int
    for (var Int u) 0 mapping:size-2 step 2
      var Int i := mapping u ; var Int j := mapping u+1
      bytes_copy (src_pixels translate Byte i) src_gamut:pixel_size (dest_pixels translate Byte j) dest_gamut:pixel_size count
      if i<src_gamut:transparency and j<dest_gamut:transparency
        bytes_copy (src_pixels translate Byte src_gamut:dimension+i) src_gamut:pixel_size (dest_pixels translate Byte dest_gamut:dimension+j) dest_gamut:pixel_size count
      eif src_gamut:transparency=0 and j<dest_gamut:transparency
        bytes_fill (dest_pixels translate Byte dest_gamut:dimension+j) dest_gamut:pixel_size count
  eif speedup<>null and entry_type:speedup=ColorGridConversion
    var Link:ColorGridConversion gconv :> speedup map ColorGridConversion
    var Address s := src_pixels ; var Int src_psize := src_gamut pixel_size
    var Address stop := src_pixels translate Byte count*src_psize
    var Address d := dest_pixels ; var Int dest_psize := dest_gamut pixel_size
    while s<>stop
      if s<>src_pixels and not (memory_different s src_psize (s translate Byte -src_psize) src_psize)
        memory_copy (d translate Byte -dest_psize) d dest_psize
      else
        gconv apply s src_gamut d dest_gamut
      s := s translate Byte src_psize ; d := d translate Byte dest_psize
    transparency_convert src_pixels src_gamut dest_pixels dest_gamut count
  eif speedup<>null and entry_type:speedup=ColorSplitConversion
    var Link:ColorSplitConversion sconv :> speedup map ColorSplitConversion
    var Address s := src_pixels ; var Int src_psize := src_gamut pixel_size
    var Address stop := src_pixels translate Byte count*src_psize
    var Address d := dest_pixels ; var Int dest_psize := dest_gamut pixel_size
    while s<>stop
      if s<>src_pixels and not (memory_different s src_psize (s translate Byte -src_psize) src_psize)
        memory_copy (d translate Byte -dest_psize) d dest_psize
      else
        sconv apply s src_gamut d dest_gamut
      s := s translate Byte src_psize ; d := d translate Byte dest_psize
    transparency_convert src_pixels src_gamut dest_pixels dest_gamut count
  else
    default_convert src_pixels src_gamut dest_pixels dest_gamut count


#-------------------------------------------------------------------------
#   Pre compute a color conversion


function color_gamut_compute src_gamut_name dest_gamut_name options timeout -> status
  arg Str src_gamut_name dest_gamut_name ; arg Str options ; arg Float timeout ; arg ExtendedStatus status
  var DateTime startup := datetime
  var Link:ColorGamut src :> color_gamut src_gamut_name
  var Link:ColorGamut dest :> color_gamut dest_gamut_name
  if src=failure
    return src
  if dest=failure
    return dest
  var Arrow speedup := dest speedup src options
  var Int i := max (cast 2^20^(1/src:dimension) Int) 2
  var Int step := max 255\(i-1) 1
  var Int total := i^src:dimension
  memory_clear addressof:(var ColorBuffer src_pixel) src:pixel_size
  var Int count := 0
  part compute "Pre computing gamut "+dest_gamut_name
    part node "computing node "+string:count+"/"+string:total+"  ("+(string 100*count\total)+"% in "+(string datetime:seconds-startup:seconds "fixed 0")+" seconds)"
      dest convert src addressof:src_pixel addressof:(var ColorBuffer dest_pixel) 1 speedup
    var Int i := src:dimension-1
    while (addressof:src_pixel map uInt8 i)+step>255
      if i=0
        leave compute
      i -= 1
    addressof:src_pixel map uInt8 i += step
    i += 1
    while i<src:dimension
      addressof:src_pixel map uInt8 i := 0
      i += 1
    count += 1
    if timeout=defined and datetime:seconds-startup:seconds>=timeout
      return failure:"timeout"
    restart compute
  status := success

# color_gamut_compute "pantone:process_cyan+process_magenta+process_yellow+process_black" "iris_heliosam2:cyan+magenta+yellow+black" 21600


#-------------------------------------------------------------------------
#   Gimp-print calibration profile generator


method conv dump filename src_gamut dest_gamut
  arg_rw ColorGridConversion conv ; arg Str filename ; oarg ColorGamut src_gamut dest_gamut
  implicit conv
    check mapping:size=steps^dim*dest_gamut:dimension
    for (var Int i) 0 steps^dim-1
      conv compute_node i src_gamut dest_gamut
      console "computing color profile ("+(string i*100\steps^dim)+"%)   [cr]"
    (var Stream s) open filename out+safe
    s writeline "Pliant calibration profile for Gimp-print"
    s writeline "pliant_release "+(string pliant_release_number)
    s writeline "source_gamut "+(string src_gamut:name)
    s writechars "source_sampling"
    for (var Int i) 0 steps-1
      s writechars " "+(string i*255\(steps-1))
    s writeline ""
    s writeline "destination_gamut "+(string dest_gamut:name)
    s writeline "destination_maximum 65535" # assuming Gimp-print CMYK16
    s writeline ""
    for (var Int i) 0 steps^dim-1
      for (var Int d) 0 dim-1
        var Int l := i\(steps^d)%steps
        l := l*255\(steps-1)
        s writechars (shunt d=0 "" " ")+string:l
      s writechars " :"
      var Pointer:(Array Float32 gamut_maximum_dimension) result :> (addressof:(mapping i*dest_gamut:dimension) map (Array Float32 gamut_maximum_dimension))
      dest_gamut encode result addressof:(var ColorBuffer pixel)
      for (var Int d) 0 dest_gamut:dimension-1
        var Int l := pixel:bytes d
        l := l*l+2*l
        s writechars " "+string:l
      s writeline ""
    console (repeat 60 " ") eol


function color_gamut_profile src_gamut_name dest_gamut_name filename steps
  arg Str src_gamut_name dest_gamut_name filename ; arg Int steps
  var Link:ColorGamut src_gamut :> color_gamut src_gamut_name
  var Link:ColorGamut dest_gamut :> color_gamut dest_gamut_name
  var Link:ColorGridConversion conv :> new ColorGridConversion 
  var Int dim := src_gamut:dimension
  var Int default_steps := shunt dim<=3 and src_gamut:model=color_gamut_additive 33 dim<=4 17 dim<=6 9 5
  conv compute src_gamut dest_gamut (shunt steps=defined steps default_steps) true
  conv dump filename src_gamut dest_gamut

function color_gamut_profile src_gamut_name dest_gamut_name filename
  arg Str src_gamut_name dest_gamut_name filename
  color_gamut_profile src_gamut_name dest_gamut_name filename undefined

export color_gamut_compute color_gamut_profile