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


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"
abstract
  ['ColorGamut' data type is defining how a pixel is encoded


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
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






constant white_mapping true


type ColorComponent
  field Link:ColorInk ink
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 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
  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 gamut dispatch_pixel pixel plus minus
  arg ColorGamutSubstractive gamut ; arg Address pixel plus 
  field CBool multiple_transparency <- false
  field CBool no_opacity <- false
  field CBool reverse_printing <- false
  field Int negatives <- 0
  
ColorGamut maybe ColorGamutSubstractive



method gamut dispatch_pixel pixel plus minus
  arg ColorGamutSubstractive gamut ; arg Address pixel plus 
  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) I
  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 ; ar
  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
method gamut simulate2 pixel -> filter
  oarg ColorGamutSubstractive gamut ; arg Address pixel ; ar
  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
    else
      var Pointer:ColorSpectrum32 s0 :> gamut:component:0:in
      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
        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 di
          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 m
      else
        plus := 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 ColorSpectru
      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
            check positive
            var ColorSpectrum32 fi := (c:ink:filter p)/(c:in
            filter *= fi
            strongest := min strongest fi
          else
            check positive
            filter := filter*(c:ink:filter p)/(c:ink:filter 
      if has_deaden
        filter := strongest*(filter/strongest)^(1/(1+gamut:d
      if gamut:component:size>gamut_maximum_dimension
        memory_free plus ; memory_free minus
    if gamut:specular>0
      filter := (1-gamut:specular)*filter+(cast gamut:specul
            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 ; ar
  color := filter_XYZ (gamut simulate2 pixel)

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" Str)






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:si
  c mask := 0
  var Str all := inks ; c:indice size := 0
  while all<>""
    if not (all parse any:(var Str ink) "+" any:(var Str rem
      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
  g:component size += 1
  var Pointer:ColorComponent c :> g:component g:component:si
  c mask := 0
  var Str all := inks ; c:indice size := 0
  while all<>""
    if not (all parse any:(var Str ink) "+" any:(var Str rem
      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
    all := remain
  if c:indice:size<2
    g:component size -= 1
    return
    return failure
  c ink :> color_ink device+inks
  c name := inks
  c ink :> color_ink device+inks
  c name := inks
  status := success



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 
    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=ColorGamutSubstractive
        var Pointer:ColorGamutSubstractive gs :> addressof:g
        gs model := color_gamut_substractive



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 
    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=ColorGamutSubstractive
        var Pointer:ColorGamutSubstractive gs :> addressof:g
        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_ma
        while inks<>""
          if not (inks parse any:(var Str ink) "+" any:(var 
            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)
              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
        inks := replace inks "cmyk" "process_cyan+process_ma
        while inks<>""
          if not (inks parse any:(var Str ink) "+" any:(var 
            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)
              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 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:devic
        if (opt option "composed")
          each ch color_database:data:device:device:channel 
            if (keyof:ch search "+" -1)<>(-1)
          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)
              gs add_component device+":" keyof:ch
        gs device := device
        gs options := color_database:data:device:device opti
        gs specular := gs:options option "final_specular" Fl
        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:Ca
    else
      cache_cancel ((addressof Link:ColorGamut g) map Link:C
      var ExtendedStatus status := g status
      g :> new ColorGamut
      g status := status


export color_gamut_compute color_gamut_profile
    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


export color_gamut_compute color_gamut_profile