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


abstract
  ['ColorGamut' data type is defining how a pixel is encoded


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

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


type ColorGamutSubstractive
  inherit ColorGamut
  field Array:ColorComponent component
  method g formulate color pixel
    oarg ColorGamut g ; arg ColorXYZ color ; arg Address pix
    generic


type ColorGamutSubstractive
  inherit ColorGamut
  field Array:ColorComponent component
  field Float specular <- 0
  field Str device options
  field CBool multiple_transparency <- false
  field CBool no_opacity <- true
  field Int negatives <- 0
  
ColorGamut maybe ColorGamutSubstractive



  field Str device options
  field CBool multiple_transparency <- false
  field CBool no_opacity <- true
  field Int negatives <- 0
  
ColorGamut maybe ColorGamutSubstractive



function exposure x gg -> y
  arg Float x gg y
  var Float g := -8*gg
  y := ((exp x*g)-1)/(exp:g-1)
  if y=undefined
    y := x


method gamut simulate pixel -> color
  oarg ColorGamutSubstractive gamut ; arg Address pixel ; ar
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
    var ColorBuffer plus_buffer minus_buffer
    var Address plus minus
    if gamut:component:size<=gamut_maximum_dimension
      plus := addressof plus_buffer ; minus := addressof min
    else
      plus := memory_allocate gamut:component:size null ; mi
    gamut dispatch_pixel addressof:pixel2 plus minus
    if white_mapping
  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
    var ColorBuffer plus_buffer minus_buffer
    var Address plus minus
    if gamut:component:size<=gamut_maximum_dimension
      plus := addressof plus_buffer ; minus := addressof min
    else
      plus := memory_allocate gamut:component:size null ; mi
    gamut dispatch_pixel addressof:pixel2 plus minus
    if white_mapping
      var ColorSpectrum32 filter := cast 1 ColorSpectrum32
      filter := cast 1 ColorSpectrum32
    else
      var Pointer:ColorSpectrum32 s0 :> gamut:component:0:in
      var Float Y0 := illuminant_spectrum*s0 Y
    else
      var Pointer:ColorSpectrum32 s0 :> gamut:component:0:in
      var Float Y0 := illuminant_spectrum*s0 Y
      var ColorSpectrum32 filter := (1/Y0)*s0
      filter := (1/Y0)*s0
    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
        else
          check positive
          filter := filter*(c:ink:filter p)/(c:ink:filter m)
    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
        else
          check positive
          filter := filter*(c:ink:filter p)/(c:ink:filter m)
    color := filter_XYZ filter
    if gamut:component:size>gamut_maximum_dimension
      memory_free plus ; memory_free minus

    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)

function distance c1 c2 -> d
  arg ColorXYZ c1 c2 ; arg Float d
  d := cmc_distance c1 c2


function distance c1 c2 -> d
  arg ColorXYZ c1 c2 ; arg Float d
  d := cmc_distance c1 c2


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
    if (gamut:options option "initial"+string:i)
      pixel map uInt8 i := cast (gamut:options option "initial"+string:i Float)*255 Int

method gamut try_formulate color pixel b0 b1 -> distance
  oarg ColorGamutSubstractive gamut ; arg ColorXYZ color ; a
  if gamut:dimension>=4
    var Float best := 1e10 ; var Int black
    (var Array:Int using) size := 3 ; using 2 := 3
    for using:0 0 gamut:dimension-1
      for using:1 using:0+1 gamut:dimension-1
        if using:0<>3 and using:1<>3
          memory_clear pixel gamut:pixel_size
          var Float d := gamut try_formulate color pixel usi
          if d<best
            best := d ; black := pixel map uInt8 3
    using 0 := 0 ; using 1 := 1 ; using 2 := 2
    memory_clear pixel gamut:pixel_size ; pixel map uInt8 3 
    var Float d := gamut try_formulate color pixel using
    if d<best
      best := d ; black := 255
    if black>=b1
      void
    eif black<b0
      black := 0
    else
      black := b1*(black-b0)\(b1-b0)
method gamut try_formulate color pixel b0 b1 -> distance
  oarg ColorGamutSubstractive gamut ; arg ColorXYZ color ; a
  if gamut:dimension>=4
    var Float best := 1e10 ; var Int black
    (var Array:Int using) size := 3 ; using 2 := 3
    for using:0 0 gamut:dimension-1
      for using:1 using:0+1 gamut:dimension-1
        if using:0<>3 and using:1<>3
          memory_clear pixel gamut:pixel_size
          var Float d := gamut try_formulate color pixel usi
          if d<best
            best := d ; black := pixel map uInt8 3
    using 0 := 0 ; using 1 := 1 ; using 2 := 2
    memory_clear pixel gamut:pixel_size ; pixel map uInt8 3 
    var Float d := gamut try_formulate color pixel using
    if d<best
      best := d ; black := 255
    if black>=b1
      void
    eif black<b0
      black := 0
    else
      black := b1*(black-b0)\(b1-b0)
    memory_clear pixel gamut:pixel_size ; pixel map uInt8 3 
    gamut fill_pixel pixel ; pixel map uInt8 3 := black
    using 0 := 0 ; using 1 := 1 ; using 2 := 2
    distance := gamut try_formulate color pixel using
  else
    using 0 := 0 ; using 1 := 1 ; using 2 := 2
    distance := gamut try_formulate color pixel using
  else
    gamut fill_pixel pixel
    (var Array:Int using) size := gamut dimension
    for (var Int i) 0 using:size-1
      using i := i
    (var Array:Int using) size := gamut dimension
    for (var Int i) 0 using:size-1
      using i := i
    memory_clear pixel gamut:pixel_size
    distance := gamut try_formulate color pixel using


function color_gamut name options -> g
  arg Str name options ; arg Link:ColorGamut g
  if name="rgb"
    g :> rgb_gamut name 0 0 false options
  eif name="rgb32"
    g :> rgb_gamut name 0 1 false options
  eif name="bgr"
    g :> rgb_gamut name 0 0 true options
  eif name="bgr32"
    g :> rgb_gamut name 0 1 true options
  eif name="rgba"
    g :> rgb_gamut name 1 0 false options
  eif name="grey"
    g :> new ColorGamut
    g name := "grey"
    g pixel_size := 1
    g dimension := 1
    g model := color_gamut_additive
  eif (name parse any:(var Str device) ":" any:(var Str inks
    var Link:ColorGamutSubstractive gs :> new ColorGamutSubs
    gs name := name
    gs model := color_gamut_substractive
    inks := replace inks "cmyk" "process_cyan+process_magent
    while inks<>""
      if not (inks parse any:(var Str ink) "+" any:(var Str 
        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) 
        if gc:ink=failure
          g :> new ColorGamut
          g name := name
          g status := failure (shunt (exists color_database:
          return
        gc mask := 2^dim
        if (gc:ink:options option "negative")
          gs negatives += 2^dim
        dim += 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:device:de
    if not (opt option "nocomposed")
      each ch color_database:data:device:device:channel
        if (keyof:ch search "+" -1)<>(-1)
          gs add_component device+":" keyof:ch
    distance := gamut try_formulate color pixel using


function color_gamut name options -> g
  arg Str name options ; arg Link:ColorGamut g
  if name="rgb"
    g :> rgb_gamut name 0 0 false options
  eif name="rgb32"
    g :> rgb_gamut name 0 1 false options
  eif name="bgr"
    g :> rgb_gamut name 0 0 true options
  eif name="bgr32"
    g :> rgb_gamut name 0 1 true options
  eif name="rgba"
    g :> rgb_gamut name 1 0 false options
  eif name="grey"
    g :> new ColorGamut
    g name := "grey"
    g pixel_size := 1
    g dimension := 1
    g model := color_gamut_additive
  eif (name parse any:(var Str device) ":" any:(var Str inks
    var Link:ColorGamutSubstractive gs :> new ColorGamutSubs
    gs name := name
    gs model := color_gamut_substractive
    inks := replace inks "cmyk" "process_cyan+process_magent
    while inks<>""
      if not (inks parse any:(var Str ink) "+" any:(var Str 
        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) 
        if gc:ink=failure
          g :> new ColorGamut
          g name := name
          g status := failure (shunt (exists color_database:
          return
        gc mask := 2^dim
        if (gc:ink:options option "negative")
          gs negatives += 2^dim
        dim += 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:device:de
    if not (opt option "nocomposed")
      each ch color_database:data:device:device:channel
        if (keyof:ch search "+" -1)<>(-1)
          gs add_component device+":" keyof:ch
    gs specular := opt option "specular" Float 0
    gs device := device
    gs options := color_database:data:device:device options
    gs no_opacity := options option "no_opacity"
    gs status := success
    g :> gs 
  else
    g :> new ColorGamut
    g name := name
    g status := failure "Unsuppoted color gamut name ("+name
    console "no '"+name+"' gamut" eol
  plugin extra_gamuts


type ColorSplitConversion
  field Array:ColorPartConversion part
  field CBool single <- false
  field CBool opacity <- false
    gs device := device
    gs options := color_database:data:device:device options
    gs no_opacity := options option "no_opacity"
    gs status := success
    g :> gs 
  else
    g :> new ColorGamut
    g name := name
    g status := failure "Unsuppoted color gamut name ("+name
    console "no '"+name+"' gamut" eol
  plugin extra_gamuts


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


function color_split_conversion src_gamut dest_gamut device 
  oarg ColorGamut src_gamut dest_gamut ; arg Data:ColorDevic
  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)=ColorGamutSubst
    for (var Int i) 0 src_gamut:dimension-1
      var Pointer:ColorInk ink1 :> (addressof:src_gamut map 
      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 "+st
    while component:size>0
      var Int best_count := 0 ; var Str best_grid ; var Int 
      if (options option "grid" Str)<>""
        var Str all := options option "grid" Str ; var Int c
        while all<>""
          if not (all parse any:(var Str ink) "+" any:(var S
            ink := all ; remain := ""
          if exists:(component first ink)
            count += 1
          all := remain
        best_count := count ; best_grid := options option "g
      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
              ink := all ; remain := ""
            if exists:(component first ink)
              count += 1
            all := remain
          if count>best_count
            best_count := count ; best_grid := keyof g ; bes
      if best_count>1
        console "  conversion grid "  best_grid eol
        var ColorPartConversion part
        part:mapping size := 0
        var Str all := best_grid
        while all<>""
          if not (all parse any:(var Str ink) "+" any:(var S
            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
        if part:gamut=failure
          console "Incorrect gamut " keyof:device+":"+best_g
          conv :> null map ColorSplitConversion
          return
        part grid :> color_grid_conversion part:gamut dest_g
        conv part += part
      else
        each comp component
          var ColorPartConversion part
          part:mapping size := 1
          part:mapping 0 := comp
          part gamut :> color_gamut keyof:device+":"+(compon
          if part:gamut=failure
            console "Incorrect gamut " keyof:device+":"+(com
            conv :> null map ColorSplitConversion
            return
          part grid :> color_grid_conversion part:gamut dest
          conv part += part
        component := var (Dictionary Str Int) empty_dict
    field uInt cache_size


function color_split_conversion src_gamut dest_gamut device 
  oarg ColorGamut src_gamut dest_gamut ; arg Data:ColorDevic
  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)=ColorGamutSubst
    for (var Int i) 0 src_gamut:dimension-1
      var Pointer:ColorInk ink1 :> (addressof:src_gamut map 
      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 "+st
    while component:size>0
      var Int best_count := 0 ; var Str best_grid ; var Int 
      if (options option "grid" Str)<>""
        var Str all := options option "grid" Str ; var Int c
        while all<>""
          if not (all parse any:(var Str ink) "+" any:(var S
            ink := all ; remain := ""
          if exists:(component first ink)
            count += 1
          all := remain
        best_count := count ; best_grid := options option "g
      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
              ink := all ; remain := ""
            if exists:(component first ink)
              count += 1
            all := remain
          if count>best_count
            best_count := count ; best_grid := keyof g ; bes
      if best_count>1
        console "  conversion grid "  best_grid eol
        var ColorPartConversion part
        part:mapping size := 0
        var Str all := best_grid
        while all<>""
          if not (all parse any:(var Str ink) "+" any:(var S
            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
        if part:gamut=failure
          console "Incorrect gamut " keyof:device+":"+best_g
          conv :> null map ColorSplitConversion
          return
        part grid :> color_grid_conversion part:gamut dest_g
        conv part += part
      else
        each comp component
          var ColorPartConversion part
          part:mapping size := 1
          part:mapping 0 := comp
          part gamut :> color_gamut keyof:device+":"+(compon
          if part:gamut=failure
            console "Incorrect gamut " keyof:device+":"+(com
            conv :> null map ColorSplitConversion
            return
          part grid :> color_grid_conversion part:gamut dest
          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*(u


method conv apply src_pixel src_gamut dest_pixel dest_gamut
  arg_rw ColorSplitConversion conv ; arg Address src_pixel ;
  # check (entry_type addressof:src_gamut)=ColorGamutSubstra
  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 Byt
    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
          memory_copy (ptr translate Byte src_psize) dest_pi
          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 de
  else
    var Address ptr0
    if conv:opacity
      (addressof:src_gamut map ColorGamutSubstractive) apply
      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 par
        else
          addressof:pixel1 map uInt8 j := 0
      var ColorBuffer pixel2
      conv:part:i:grid apply addressof:pixel1 part:gamut add
      dest_gamut decode addressof:pixel2 (var (Array Float32
      for (var Int j) 0 dest_gamut:dimension-1
        result j += f:j*(1-result:j)
  if hash_conversion
    conv cache_size := options option "hash" Int 63541
    conv cache_buffer := memory_zallocate conv:cache_size*(u


method conv apply src_pixel src_gamut dest_pixel dest_gamut
  arg_rw ColorSplitConversion conv ; arg Address src_pixel ;
  # check (entry_type addressof:src_gamut)=ColorGamutSubstra
  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 Byt
    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
          memory_copy (ptr translate Byte src_psize) dest_pi
          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 de
  else
    var Address ptr0
    if conv:opacity
      (addressof:src_gamut map ColorGamutSubstractive) apply
      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 par
        else
          addressof:pixel1 map uInt8 j := 0
      var ColorBuffer pixel2
      conv:part:i:grid apply addressof:pixel1 part:gamut add
      dest_gamut decode addressof:pixel2 (var (Array Float32
      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) de
    sem := 1



export color_gamut_compute color_gamut_profile
    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) de
    sem := 1



export color_gamut_compute color_gamut_profile