/pliant/graphic/color/gamut.pli
 
 1  abstract 
 2    ['ColorGamut' data type is defining how a pixel is encoded, I mean the meaning of various bits.] 
 3   
 4  # Copyright  Hubert Tonneau  hubert.tonneau@pliant.cx 
 5  # Copyright  Heliogroup 
 6  # 
 7  # This program is free software; you can redistribute it and/or 
 8  # modify it under the terms of the GNU General Public License version 2 
 9  # as published by the Free Software Foundation. 
 10  # 
 11  # This program is distributed in the hope that it will be useful, 
 12  # but WITHOUT ANY WARRANTY; without even the implied warranty of 
 13  # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the 
 14  # GNU General Public License for more details. 
 15  # 
 16  # You should have received a copy of the GNU General Public License 
 17  # version 2 along with this program; if not, write to the Free Software 
 18  # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA. 
 19   
 20   
 21  module "/pliant/language/compiler.pli" 
 22  module "/pliant/language/context.pli" 
 23  module "/pliant/language/os.pli" 
 24  module "/pliant/language/compiler/type/inherit.pli" 
 25  module "/pliant/math/functions.pli" 
 26  module "/pliant/math/curven.pli" 
 27  module "/pliant/math/matrix.pli" 
 28  module "color.pli" 
 29  module "ink.pli" 
 30  module "gradation.pli" 
 31  module "spectrum.pli" 
 32  module "/pliant/graphic/misc/int.pli" 
 33  module "/pliant/graphic/misc/float.pli" 
 34  module "/pliant/graphic/misc/bytes.pli" 
 35  module "/pliant/graphic/misc/vector.pli" 
 36  module "/pliant/language/stream.pli" 
 37  module "/pliant/admin/md5.pli" 
 38  module "database.pli" 
 39  module "adjust.pli" 
 40  module "/pliant/language/data/cache.pli" 
 41   
 42  constant hash_conversion true 
 43  constant hash_rgb true 
 44  constant direct_is_linear true 
 45   
 46  constant verify false 
 47  if verify 
 48    gvar CBool advanced 
 49  else 
 50    constant advanced true 
 51  constant advanced2 true 
 52   
 53   
 54 
 
 55  #   prototype 
 56   
 57   
 58  public 
 59   
 60    constant color_gamut_additive 1 
 61    constant color_gamut_substractive 2 
 62    constant gamut_maximum_dimension 32 
 63     
 64    type ColorBuffer 
 65      field (Array uInt8 gamut_maximum_dimension) bytes 
 66   
 67    type ColorGamut 
 68      inherit CachePrototype 
 69      field Int pixel_size 
 70      field Int dimension 
 71      field Int transparency <- 0 
 72      field Int padding <- 0 
 73      field Int bits_per_component <- 8 
 74      field Str name 
 75      field Int model <- 0 
 76      field ExtendedStatus status <- failure 
 77   
 78    CachePrototype maybe ColorGamut 
 79     
 80    method p update stream -> status # avoid clashing with CachePrototype 
 81      oarg_rw ColorGamut p ; arg_rw Stream stream ; arg ExtendedStatus status 
 82      generic 
 83      status := failure "not implemented" 
 84     
 85    method p dump stream -> status 
 86      oarg_rw ColorGamut p ; arg_rw Stream stream ; arg ExtendedStatus status 
 87      generic 
 88      status := failure "not implemented" 
 89   
 90    method p sleep 
 91      oarg_rw ColorGamut p 
 92      generic 
 93   
 94    method p drop 
 95      oarg_rw ColorGamut p 
 96      generic 
 97   
 98    method g decode pixel components 
 99      oarg ColorGamut g ; arg Address pixel ; arg_w (Array Float32 gamut_maximum_dimension) components 
 100      generic 
 101   
 102    method g encode components pixel 
 103      oarg ColorGamut g ; arg (Array Float32 gamut_maximum_dimension) components ; arg Address pixel 
 104      generic 
 105   
 106    method g opacity_decode pixel opacity 
 107      oarg ColorGamut g ; arg Address pixel ; arg_w (Array Float32 gamut_maximum_dimension) opacity 
 108      generic 
 109      if g:transparency=0 
 110        for (var Int i) g:dimension-1 
 111          opacity := 1 
 112      eif g:transparency=1 
 113        for (var Int i) g:dimension-1 
 114          opacity := (pixel map uInt8 g:dimension)/255 
 115      eif g:transparency=g:dimension 
 116        for (var Int i) g:dimension-1 
 117          opacity := (pixel map uInt8 g:dimension+i)/255 
 118      else 
 119        error "Inconsistent transparency in gamut "+g:name 
 120   
 121    method g opacity_encode opacity pixel 
 122      oarg ColorGamut g ; arg (Array Float32 gamut_maximum_dimension) opacity ; arg Address pixel 
 123      generic 
 124      if g:transparency=1 
 125        pixel map uInt8 g:dimension := bound (cast opacity:0*255 Int) 0 255 
 126      eif g:transparency=g:dimension 
 127        for (var Int i) g:dimension-1 
 128          pixel map uInt8 g:dimension+:= bound (cast opacity:i*255 Int) 0 255 
 129   
 130    method g simulate pixel -> color 
 131      oarg ColorGamut g ; arg Address pixel ; arg ColorXYZ color 
 132      generic 
 133   
 134    method g simulate2 pixel -> filter 
 135      oarg ColorGamut g ; arg Address pixel ; arg ColorSpectrum32 filter 
 136      generic 
 137      filter := var ColorSpectrum empty_spectrum 
 138   
 139    method g formulate color options pixel 
 140      oarg ColorGamut g ; arg ColorXYZ color ; arg Str options ; arg Address pixel 
 141      generic 
 142   
 143    method g formulate color pixel 
 144      oarg ColorGamut g ; arg ColorXYZ color ; arg Address pixel 
 145      formulate color "" pixel 
 146   
 147    method g speedup src_gamut options -> speedup 
 148      oarg ColorGamut src_gamut ; arg Str options ; arg Arrow speedup 
 149      generic 
 150      speedup := null 
 151   
 152    method g query question -> answer 
 153      oarg ColorGamut g ; arg Str question answer 
 154      generic 
 155      answer := "" 
 156   
 157    method g configure parameter value -> status 
 158      oarg_rw ColorGamut g ; arg Str parameter value ; arg ExtendedStatus status 
 159      generic 
 160      status := failure "unsupported" 
 161   
 162    function 'cast ExtendedStatus' g -> status 
 163      arg ColorGamut g; arg ExtendedStatus status 
 164      extension 
 165      status := status 
 166   
 167   
 168  function transparency_convert src_pixels src_gamut dest_pixels dest_gamut count 
 169    arg Address src_pixels dest_pixels ; oarg ColorGamut src_gamut dest_gamut ; arg Int count 
 170    if dest_gamut:transparency=0 
 171      return 
 172    var Address src := src_pixels translate Byte src_gamut:dimension ; var Int src_psize := src_gamut pixel_size 
 173    var Address dest := dest_pixels translate Byte dest_gamut:dimension ; var Int dest_psize := dest_gamut pixel_size 
 174    var Address stop := dest translate Byte count*dest_psize 
 175    if src_gamut:transparency=0 
 176      while dest<>stop 
 177        dest map uInt8 := 255 
 178        dest := dest translate Byte dest_psize     
 179    eif src_gamut:transparency=1 
 180      while dest<>stop 
 181        dest map uInt8 := src map uInt8 
 182        src := src translate Byte src_psize ; dest := dest translate Byte dest_psize 
 183    else 
 184      var Int last := src_gamut:transparency-1 
 185      while dest<>stop 
 186        var Int opacity := 0 
 187        for (var Int i) last 
 188          opacity := max opacity (src map uInt8 i) 
 189        dest map uInt8 := opacity 
 190        src := src translate Byte src_psize ; dest := dest translate Byte dest_psize 
 191    if dest_gamut:transparency>1 
 192      var Address dest := dest_pixels translate Byte dest_gamut:dimension 
 193      var Address stop := dest translate Byte count*dest_psize 
 194      var Int last := dest_gamut:transparency-1 
 195      while dest<>stop 
 196        var Int opacity := dest map uInt8 
 197        for (var Int i) last 
 198          dest map uInt8 := opacity 
 199        dest := dest translate Byte dest_psize     
 200   
 201  function default_convert src_pixels src_gamut dest_pixels dest_gamut count 
 202    arg Address src_pixels dest_pixels ; oarg ColorGamut src_gamut dest_gamut ; arg Int count 
 203    var Str options := (dest_gamut query "options"option "convert_adjust" Str 
 204    var Address := src_pixels ; var Int src_psize := src_gamut pixel_size 
 205    var Address stop := src_pixels translate Byte count*src_psize 
 206    var Address := dest_pixels ; var Int dest_psize := dest_gamut pixel_size 
 207    while s<>stop 
 208      if s<>src_pixels and not (memory_different src_psize (translate Byte -src_psize) src_psize) 
 209        memory_copy (translate Byte -dest_psize) dest_psize 
 210      else 
 211        var ColorXYZ color := src_gamut simulate s 
 212        color_adjust color options 
 213        dest_gamut formulate color d 
 214      := translate Byte src_psize ; := translate Byte dest_psize 
 215    transparency_convert src_pixels src_gamut dest_pixels dest_gamut count 
 216   
 217  method dest_gamut convert src_gamut src_pixels dest_pixels count speedup 
 218    oarg ColorGamut dest_gamut src_gamut ; arg Address src_pixels dest_pixels ; arg Int count ; arg Address speedup 
 219    generic 
 220    default_convert src_pixels src_gamut dest_pixels dest_gamut count 
 221   
 222  export '. convert' 
 223   
 224   
 225 
 
 226  #   additive (RGB) 
 227   
 228   
 229  type ColorGamutRGB 
 230    inherit ColorGamut 
 231    field CBool reversed 
 232    field Str options 
 233     
 234  ColorGamut maybe ColorGamutRGB 
 235   
 236   
 237  method g decode pixel components 
 238    oarg ColorGamutRGB g ; arg Address pixel ; arg_w (Array Float32 gamut_maximum_dimension) components 
 239    addressof:components map ColorRGB := pixel map ColorRGB888 
 240   
 241  method g encode components pixel 
 242    oarg ColorGamutRGB g ; arg (Array Float32 gamut_maximum_dimension) components ; arg Address pixel 
 243    pixel map ColorRGB888 := addressof:components map ColorRGB 
 244     
 245  method g query question -> answer 
 246    oarg ColorGamutRGB g ; arg Str question answer 
 247    if question="options" 
 248      answer := options 
 249    else 
 250      answer := "" 
 251   
 252  method g configure parameter value -> status 
 253    oarg_rw ColorGamutRGB g ; arg Str parameter value ; arg ExtendedStatus status 
 254    if parameter="options" 
 255      options := value 
 256    else 
 257      status := failure "unsupported" 
 258   
 259  method g simulate pixel -> color 
 260    oarg ColorGamutRGB g ; arg Address pixel ; arg ColorXYZ color 
 261    var Address rgb 
 262    if g:reversed 
 263      rgb := addressof (var Int32 buffer) 
 264      for (var Int c) 0 2 
 265        rgb map uInt8 := pixel map uInt8 2-c 
 266    else 
 267      rgb := pixel 
 268    color := cast (rgb map ColorRGB888) ColorXYZ 
 269   
 270  method g formulate color options pixel 
 271    oarg ColorGamutRGB g ; arg ColorXYZ color ; arg Str options ; arg Address pixel 
 272    var ColorRGB888 rgb := cast color ColorRGB888 
 273    if g:reversed 
 274      for (var Int c) 0 2 
 275        pixel map uInt8 := addressof:rgb map uInt8 2-c 
 276    else 
 277      pixel map ColorRGB888 := rgb 
 278   
 279   
 280 
 
 281  #   additive (XYZ) 
 282   
 283   
 284  type ColorGamutXYZ 
 285    inherit ColorGamut 
 286     
 287  ColorGamut maybe ColorGamutXYZ 
 288   
 289   
 290  method g decode pixel components 
 291    oarg ColorGamutXYZ g ; arg Address pixel ; arg_w (Array Float32 gamut_maximum_dimension) components 
 292    memory_copy pixel addressof:components 3*Float32:size 
 293   
 294  method g encode components pixel 
 295    oarg ColorGamutXYZ g ; arg (Array Float32 gamut_maximum_dimension) components ; arg Address pixel 
 296    memory_copy addressof:components pixel 3*Float32:size 
 297     
 298  method g simulate pixel -> color 
 299    oarg ColorGamutXYZ g ; arg Address pixel ; arg ColorXYZ color 
 300    memory_copy pixel addressof:color 3*Float32:size 
 301   
 302  method g formulate color options pixel 
 303    oarg ColorGamutXYZ g ; arg ColorXYZ color ; arg Str options ; arg Address pixel 
 304    memory_copy addressof:color pixel 3*Float32:size 
 305   
 306   
 307 
 
 308  #   grid based conversion 
 309   
 310   
 311  constant grid_conversion_release 13 
 312   
 313   
 314  type ColorGridConversion 
 315    inherit CachePrototype 
 316    field Array:Float32 mapping 
 317    field Int dim 
 318    field Int steps 
 319    field Int done 
 320    field Int computed 
 321    field Str key 
 322    field CBool inheritate 
 323    field Link:Function convert_function 
 324    field Str convert_name 
 325    field Arrow convert_param 
 326   
 327  CachePrototype maybe ColorGridConversion 
 328   
 329   
 330  function standard_convert_function src_pixel src_gamut dest_pixel dest_gamut param 
 331    arg Address src_pixel ; oarg ColorGamut src_gamut ; arg Address dest_pixel ; oarg ColorGamut dest_gamut ; arg Address param 
 332    var Str options := (dest_gamut query "options"option "convert_adjust" Str 
 333    var ColorXYZ color := src_gamut simulate src_pixel 
 334    color_adjust color options 
 335    dest_gamut formulate color dest_pixel 
 336   
 337  method conv compute src_gamut dest_gamut steps cached inheritate 
 338    arg_w ColorGridConversion conv ; oarg ColorGamut src_gamut dest_gamut ; arg Int steps ; arg CBool cached inheritate 
 339    var Int dim := src_gamut dimension 
 340    conv dim := dim 
 341    conv steps := steps 
 342    conv:mapping size := steps^dim*dest_gamut:dimension 
 343    for (var Int i) steps^dim-1 
 344      conv:mapping i*dest_gamut:dimension := undefined 
 345    conv done := 0 
 346    conv computed := 0 
 347    if cached 
 348      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+" "+conv:convert_name+" "+string:grid_conversion_release 
 349      (var Stream s) open "data:/pliant/graphic/cache/"+conv:key+".bin" in+safe 
 350      if s=success 
 351        while s:readline<>"" 
 352          void 
 353        raw_read (addressof conv:mapping:0) conv:mapping:size*Float32:size 
 354        if s=success 
 355          for (var Int i) steps^dim-1 
 356            if (conv:mapping i*dest_gamut:dimension)=defined 
 357              conv:done += 1 
 358        else 
 359          for (var Int i) steps^dim-1 
 360            conv:mapping i*dest_gamut:dimension := undefined 
 361    if inheritate 
 362      check cached 
 363    conv inheritate := inheritate 
 364    if not (exists conv:convert_function) 
 365      conv convert_function :> the_function standard_convert_function Address ColorGamut Address ColorGamut Address 
 366   
 367  function convert_function_prototype src_pixel src_gamut dest_pixel dest_gamut param fun 
 368    arg Address src_pixel ; oarg ColorGamut src_gamut ; arg Address dest_pixel ; oarg ColorGamut dest_gamut ; arg Address param ; arg Function fun 
 369    indirect 
 370   
 371  method conv compute_node index src_gamut dest_gamut 
 372    arg_rw ColorGridConversion conv ; arg Int index ; oarg ColorGamut src_gamut dest_gamut 
 373    var Pointer:Float32 :> conv:mapping index*dest_gamut:dimension 
 374    var ColorBuffer src_pixel dest_pixel 
 375    for (var Int d) conv:dim-1 
 376      src_pixel:bytes := (index\conv:steps^d)%conv:steps*255\(conv:steps-1) 
 377    convert_function_prototype addressof:src_pixel src_gamut addressof:dest_pixel dest_gamut conv:convert_param conv:convert_function 
 378    dest_gamut decode addressof:dest_pixel (var (Array Float32 gamut_maximum_dimension) components) 
 379    for (var Int d) dest_gamut:dimension-1 0 step -1 
 380      addressof:map Float32 := components d 
 381   
 382  function color_grid_conversion src_gamut dest_gamut steps cached -> conv 
 383    oarg ColorGamut src_gamut dest_gamut ; arg Int steps ; arg CBool cached ; arg Link:ColorGridConversion conv 
 384    later 
 385   
 386  function color_gamut name options -> g 
 387    arg Str name options ; arg Link:ColorGamut g 
 388    later 
 389   
 390  method conv compute_node2 index src_gamut dest_gamut 
 391    arg_rw ColorGridConversion conv ; arg Int index ; oarg ColorGamut src_gamut dest_gamut 
 392    if conv:inheritate and src_gamut:model=color_gamut_substractive and dest_gamut:model=color_gamut_substractive 
 393      var Int selected_dim := 0 ; var Int selected_index := 0 ; var Str selected_inks := "" 
 394      for (var Int d) conv:dim-1 
 395        var Int := (index\conv:steps^d)%conv:steps 
 396        if i<>0 
 397          selected_index += i*conv:steps^selected_dim 
 398          selected_inks += "+"+(src_gamut query "component_name "+string:d) 
 399          selected_dim += 1 
 400      if selected_dim>and selected_dim<conv:dim 
 401        var Link:ColorGamut selected_gamut :> color_gamut (src_gamut query "device")+":"+(selected_inks selected_inks:len) (src_gamut query "extra") 
 402        if selected_gamut=success 
 403          var Link:ColorGridConversion selected_conv :> color_grid_conversion selected_gamut dest_gamut conv:steps true 
 404          if (selected_conv:mapping selected_index*dest_gamut:dimension)=undefined 
 405            part compute "recurse compute lazy color conversion grid node "+(string conv:done)+"/"+(string conv:steps^conv:dim)+" ("+src_gamut:name+" -> "+dest_gamut:name+")" 
 406              selected_conv compute_node2 selected_index selected_gamut dest_gamut 
 407          for (var Int d) dest_gamut:dimension-1 0 step -1 
 408            conv:mapping index*dest_gamut:dimension+:= selected_conv:mapping selected_index*dest_gamut:dimension+d 
 409          conv done += 1 
 410          return 
 411    part compute "compute lazy color conversion grid node "+(string conv:done)+"/"+(string conv:steps^conv:dim)+" ("+src_gamut:name+" -> "+dest_gamut:name+")" 
 412      conv compute_node index src_gamut dest_gamut 
 413      conv done += 1 
 414      conv computed += 1 
 415    if conv:key<>"" 
 416      if conv:computed%(shunt dest_gamut:name="XYZ" 4096 64)=or conv:done=conv:steps^conv:dim 
 417        (var Stream s) open "data:/pliant/graphic/cache/"+conv:key+".bin" out+safe+mkdir 
 418        writeline "Pliant color conversion" 
 419        writeline "source_gamut "+(string src_gamut:name) 
 420        writeline "source_options "+string:(src_gamut query "signature") 
 421        writeline "destination_gamut "+(string dest_gamut:name) 
 422        writeline "destination_options "+string:(dest_gamut query "signature") 
 423        writeline "steps "+(string conv:steps) 
 424        writeline "release "+string:grid_conversion_release 
 425        writeline "" 
 426        raw_write (addressof conv:mapping:0) conv:mapping:size*Float32:size 
 427        close 
 428        # if not hurry 
 429        #   console "." 
 430   
 431  method conv apply src_pixel src_gamut dest_pixel dest_gamut 
 432    arg_rw ColorGridConversion conv ; arg Address src_pixel ; oarg ColorGamut src_gamut ; arg Address dest_pixel ; oarg ColorGamut dest_gamut 
 433    check conv:dim=src_gamut:dimension 
 434    check src_gamut:pixel_size=src_gamut:dimension 
 435    if true 
 436      part apply 
 437        var Int index := vector_apply_grid src_gamut:dimension dest_gamut:dimension conv:steps (addressof conv:mapping:0) src_pixel addressof:(var (Array Float32 gamut_maximum_dimension) result) 
 438        if index>=0 
 439          conv compute_node2 index src_gamut dest_gamut 
 440          restart apply 
 441    else 
 442      var Int dim := conv dim ; var Int steps := conv steps 
 443      var Int base := 0   
 444      var Int n := 0 
 445      var (Array Int gamut_maximum_dimension) gs # grid step 
 446      var (Array Float32 gamut_maximum_dimension) remain 
 447      var Int unit := 1 
 448      for (var Int d) 0 src_gamut:dimension-1 
 449        var Int v := src_pixel map uInt8 d 
 450        if v=0 
 451          void 
 452        eif v=255 
 453          base += (steps-1)*unit 
 454        else 
 455          var Int i := min v*(steps-1)\255 steps-2 
 456          gs n := unit 
 457          base += i*unit 
 458          remain n := ( v - i*255\(steps-1) ) / ( (i+1)*255\(steps-1) - i*255\(steps-1) ) 
 459          n += 1 
 460        unit *= steps 
 461      var (Array Float32 gamut_maximum_dimension) result 
 462      for (var Int d) 0 dest_gamut:dimension-1 
 463        result d := 0 
 464      for (var Int u) 0 2^n-1 
 465        var Int index := base ; var Float f := 1 
 466        for (var Int d) 0 n-1 
 467          if (u .and. 2^d)<>0 
 468            index += gs d 
 469            f *= remain d 
 470          else 
 471            f *= 1-remain:d 
 472        var Pointer:(Array Float32 gamut_maximum_dimension) p :> addressof:(conv:mapping index*dest_gamut:dimension) map (Array Float32 gamut_maximum_dimension) 
 473        if p:0=undefined 
 474          conv compute_node2 index src_gamut dest_gamut 
 475        for (var Int d) 0 dest_gamut:dimension-1 
 476          result d += f*p:d 
 477    dest_gamut encode result dest_pixel 
 478   
 479   
 480  function color_grid_conversion src_gamut dest_gamut steps cached -> conv 
 481    oarg ColorGamut src_gamut dest_gamut ; arg Int steps ; arg CBool cached ; arg Link:ColorGridConversion conv 
 482    var Int dim := src_gamut dimension 
 483    var Int steps1 := shunt steps=defined steps src_gamut:model=color_gamut_additive 33 dim<=4 17 dim<=6 9 5 
 484    var Str := (string src_gamut:name)+" "+string:(src_gamut query "signature")+" "+(string dest_gamut:name)+" "+string:(dest_gamut query "signature")+" "+string:steps1 
 485    if (cache_open "/pliant/color/conversion/"+ColorGridConversion ((addressof Link:ColorGridConversion conv) map Link:CachePrototype)) 
 486      conv compute src_gamut dest_gamut steps1 cached cached 
 487      cache_ready ((addressof Link:ColorGridConversion conv) map Link:CachePrototype) 
 488   
 489  export ColorGridConversion '. convert_function' '. convert_name' '. convert_param' '. compute' '. apply' 
 490   
 491   
 492   
 493 
 
 494  #   grid based simulation 
 495   
 496   
 497  type ColorGridSimulation 
 498    inherit CachePrototype 
 499    field Curven curve 
 500    field Array:Str ink 
 501    field CBool logarithm <- true 
 502   
 503  CachePrototype maybe ColorGridSimulation 
 504   
 505   
 506  function color_grid_simulation name -> grid 
 507    arg Str name ; arg Link:ColorGridSimulation grid 
 508    if (cache_open "/pliant/color/simulation/"+name ColorGridSimulation ((addressof Link:ColorGridSimulation grid) map Link:CachePrototype)) 
 509      (var Stream s) open "data:/pliant/graphic/color/"+name in+safe 
 510      if s=failure 
 511        cache_cancel ((addressof Link:ColorGridSimulation grid) map Link:CachePrototype) 
 512        grid :> null map ColorGridSimulation 
 513        return 
 514      var (Array Array:Float) nodes 
 515      var Array:Float middle density maxi 
 516      while not s:atend and { var Str := readline ; l<>"" } 
 517        if (parse word:"ink" (var Str inkname) any:(var Str values)) 
 518          grid ink += inkname 
 519          var Int := nodes size 
 520          nodes size += 1 
 521          middle += option "middle" Float 0 
 522          density += option "density" Float 1 
 523          maxi += option "maxi" Float 255 
 524          while (values parse (var Float f) any:(var Str remain)) 
 525            nodes nodes:size-+= (unexposure f/maxi:i/density:middle:i)*maxi:i 
 526            values := remain 
 527        eif (parse "linear") 
 528          grid logarithm := false 
 529      grid:curve resize ColorSpectrum32:size\Float32:size nodes:size nodes 
 530      var ColorSpectrum32 w32 := var ColorSpectrum32 undefined_spectrum 
 531      while not s:atend 
 532        var Str := readline 
 533        if (parse any:(var Str all) ":" (var ColorSpectrum cs) ) 
 534          (var Array:Float params) size := nodes size 
 535          for (var Int i) params:size-1 
 536            if (all parse params:any:(var Str remain)) 
 537              all := remain 
 538            else 
 539              error error_id_corrupted "Incorrect line in gamut measures files "+s:name+" ("+l+")" 
 540            params := (unexposure params:i/maxi:i/density:middle:i)*maxi:i 
 541          if w32=undefined 
 542            w32 := cs 
 543          var ColorSpectrum32 cs32 := cs/w32 
 544          (var Array:Float point) size := ColorSpectrum32:size\Float32:size 
 545          for (var Int i) point:size-1 
 546            point := addressof:cs32 map Float32 i 
 547            if grid:logarithm 
 548              point := log point:i 
 549          grid:curve define params point 
 550      cache_ready ((addressof Link:ColorGridSimulation grid) map Link:CachePrototype) 
 551   
 552   
 553  gvar (Array Int 256) bits_count_array 
 554   
 555  function init_bits_count 
 556    for (var Int i) 0 255 
 557      bits_count_array := 0 
 558      for (var Int j) 0 7 
 559        if (.and. 2^j)<>0 
 560           bits_count_array += 1 
 561  init_bits_count 
 562   
 563  function bits_count u -> n 
 564    arg uInt u ; arg Int n 
 565    := bits_count_array (.and. 255) 
 566    if u>=256 
 567      += bits_count_array u\256 
 568   
 569   
 570 
 
 571  #   substractive (inks) 
 572   
 573   
 574  type ColorComponent 
 575    field Link:ColorInk ink 
 576    field Str name 
 577   
 578  type ColorGrid 
 579    field Link:ColorGridSimulation simulation 
 580    field Array:Int indice ; field uInt mask 
 581    field Str name 
 582   
 583  type ColorFormulateUsing 
 584    field Array:Int using 
 585    field Float hue 
 586   
 587  type ColorGamutSubstractive 
 588    inherit ColorGamut 
 589    field Array:ColorComponent component 
 590    field Array:ColorGrid grid 
 591    field Array:ColorFormulateUsing formulate_using 
 592    field Str device options extra 
 593    field Float deaden <- 0 
 594    field CBool multiple_transparency <- false 
 595    field CBool no_opacity <- false 
 596    field CBool reverse_printing <- false 
 597    field Int negatives <- 0 
 598    field Link:ColorGridConversion fast_simulation 
 599    field Link:ColorGamut another_gamut 
 600    field Link:ColorGamut xyz_gamut 
 601     
 602  ColorGamut maybe ColorGamutSubstractive 
 603   
 604   
 605  method g decode pixel components 
 606    oarg ColorGamutSubstractive g ; arg Address pixel ; arg_w (Array Float32 gamut_maximum_dimension) components 
 607    for (var Int i) g:dimension-1 
 608      components := g:component:i:ink:gradation decode (pixel map uInt8 i) 
 609   
 610  method g encode components pixel 
 611    oarg ColorGamutSubstractive g ; arg (Array Float32 gamut_maximum_dimension) components ; arg Address pixel 
 612    for (var Int i) g:dimension-1 
 613      pixel map uInt8 := g:component:i:ink:gradation encode components:i 
 614   
 615  method gamut apply_opacity src dest 
 616    arg ColorGamutSubstractive gamut ; arg Address src dest 
 617    memory_copy src dest gamut:pixel_size 
 618    if gamut:reverse_printing 
 619      for (var Int i) gamut:dimension-1 0 step -1 
 620        var Pointer:ColorInk ink :> gamut:component:ink 
 621        if ink:opacity=defined and ink:opacity>0 
 622          var Float := ink:gradation decode (dest map uInt8 i) 
 623          if d>0 
 624            var Float := 1-ink:opacity*d 
 625            for (var Int j) i+gamut:dimension-1 
 626              var Pointer:uInt8 :> dest map uInt8 j 
 627              var Pointer:ColorGradation :> gamut:component:j:ink gradation 
 628              := encode (decode p)*f 
 629    else 
 630      for (var Int i) gamut:dimension-1 
 631        var Pointer:ColorInk ink :> gamut:component:ink 
 632        if ink:opacity=defined and ink:opacity>0 
 633          var Float := ink:gradation decode (dest map uInt8 i) 
 634          if d>0 
 635            var Float := 1-ink:opacity*d 
 636            for (var Int j) i-1 
 637              var Pointer:uInt8 :> dest map uInt8 j 
 638              var Pointer:ColorGradation :> gamut:component:j:ink gradation 
 639              := encode (decode p)*f 
 640   
 641  function curven_simulation g pixel -> f 
 642    arg ColorGrid g ; arg Address pixel ; arg ColorSpectrum32 f 
 643    (var Array:Float params) size := g:indice size 
 644    for (var Int i) params:size-1 
 645      var Int := g:indice i 
 646      if j<>undefined 
 647        params := pixel map uInt8 j 
 648        pixel map uInt8 := 0 
 649      else 
 650        params := 0 
 651    var Array:Float point := g:simulation:curve apply params 
 652    check point:size=ColorSpectrum32:size\Float32:size 
 653    if g:simulation:logarithm 
 654      for (var Int i) point:size-1 
 655        addressof:map Float32 := exp point:i 
 656    else 
 657      for (var Int i) point:size-1 
 658        addressof:map Float32 := point i 
 659   
 660  method gamut simulate2 pixel -> filter 
 661    oarg ColorGamutSubstractive gamut ; arg Address pixel ; arg ColorSpectrum32 filter 
 662    part simulate "substractive color simulation "+gamut:name 
 663      var ColorBuffer pixel2 
 664      if gamut:no_opacity 
 665        memory_copy pixel addressof:pixel2 gamut:pixel_size 
 666      else 
 667        gamut apply_opacity pixel addressof:pixel2 
 668      filter := cast ColorSpectrum32 
 669      var uInt mask := 0 
 670      for (var Int i) gamut:dimension-1 
 671        if (addressof:pixel2 map uInt8 i)<>0 
 672          mask += 2^i 
 673      part apply_best_grid 
 674        var Int maxi := 1 ; var Int selected := undefined 
 675        for (var Int i) gamut:grid:size-1 
 676          var Pointer:ColorGrid :> gamut:grid i 
 677          var Int := bits_count mask .and. g:mask 
 678          if n>maxi 
 679            selected := i ; maxi := n 
 680        if selected<>undefined 
 681          var Pointer:ColorGrid :> gamut:grid selected 
 682          filter += exposure (-1)*log:(curven_simulation addressof:pixel2) (-gamut:deaden) 
 683          mask := mask .and. .not. g:mask 
 684          restart apply_best_grid 
 685      for (var Int i) gamut:component:size-1 
 686        if ((mask .or. gamut:negatives) .and. 2^i)<>0 
 687          var Pointer:ColorComponent :> gamut:component i 
 688          var Pointer:ColorInk ink :> ink 
 689          if ink:deaden=gamut:deaden 
 690            filter += ink:deaden_filter (addressof:pixel2 map uInt8 i) 
 691          else 
 692            filter += exposure (-1)*(log ink:filter:(addressof:pixel2 map uInt8 i)) (-gamut:deaden) 
 693      filter := exp (-1)*(unexposure filter (-gamut:deaden)) 
 694   
 695  method gamut simulate pixel -> color 
 696    oarg ColorGamutSubstractive gamut ; arg Address pixel ; arg ColorXYZ color 
 697    if (exists gamut:fast_simulation) 
 698      ((addressof gamut:fast_simulation) omap ColorGridConversion) apply pixel gamut:another_gamut addressof:color gamut:xyz_gamut 
 699    else 
 700      color := filter_XYZ (gamut simulate2 pixel) 
 701      color_adjust color (gamut:options option "simulate_adjust" Str) 
 702   
 703  method gamut try_formulate1 wished pixel using maximum limit l c -> distance 
 704    oarg ColorGamut gamut ; arg ColorXYZ wished ; arg Address pixel ; arg Array:Int using maximum ; arg Int limit ; arg Float distance 
 705    check using:size=3 
 706    var ColorXYZ got := gamut simulate pixel 
 707    distance := cmc_distance wished got c 
 708    var Int step := 4 
 709    (var Matrix m) resize 3 3 
 710    part improve 
 711      for (var Int dim) 0 2 
 712        var Int := using dim 
 713        memory_copy pixel addressof:(var ColorBuffer pixel1) gamut:pixel_size 
 714        var Int := pixel1:bytes d 
 715        if true 
 716          var Int v1 := shunt v+step<256 v+step v-step 
 717          pixel1:bytes := v1 
 718          var ColorXYZ got1 := gamut simulate addressof:pixel1 
 719          dim := (got1:X-got:X)/(v1-v) 
 720          dim := (got1:Y-got:Y)/(v1-v) 
 721          dim := (got1:Z-got:Z)/(v1-v) 
 722        else 
 723          var Int v1 v2 
 724          if v-step\2<0 
 725            v1 := 0 ; v2 := step 
 726          eif v+step\2>255 
 727            v1 := 255-step ; v2 := 255 
 728          else 
 729            v1 := v-step\2 ; v2 := v+step\2 
 730          pixel1:bytes d := v1 
 731          var ColorXYZ got1 := gamut simulate addressof:pixel1 
 732          pixel1:bytes d := v2 
 733          var ColorXYZ got2 := gamut simulate addressof:pixel1 
 734          m 0 dim := (got2:X-got1:X)/step 
 735          m 1 dim := (got2:Y-got1:Y)/step 
 736          m 2 dim := (got2:Z-got1:Z)/step 
 737      var Matrix m1 := m^(-1) 
 738      if m1=failure 
 739        leave improve 
 740      (var Matrix diff) resize 3 1 
 741      diff 0 0 := wished:X-got:X 
 742      diff 1 0 := wished:Y-got:Y 
 743      diff 2 0 := wished:Z-got:Z 
 744      var Matrix coef := m1*diff 
 745      var CBool different := false 
 746      for (var Int dim) 0 2 
 747        if abs:(coef dim 0)>1e9 
 748          leave improve 
 749        var Int := using dim 
 750        pixel1:bytes := min (max (pixel map uInt8 d)+(cast (coef dim 0) Int) 0) maximum:d 
 751      if limit<>undefined 
 752        var Int total := 0 
 753        for (var Int d) gamut:dimension-1 
 754          total += pixel map uInt8 d 
 755        if total>limit 
 756          for (var Int d) gamut:dimension-1 
 757            pixel1:bytes := cast pixel1:bytes:d*limit/total Int 
 758      var CBool different := false 
 759      for (var Int dim) 0 2 
 760        var Int := using dim 
 761        if pixel1:bytes:d<>(pixel map uInt8 d) 
 762          different := true 
 763      if not different 
 764        leave improve 
 765      var ColorXYZ got1 := gamut simulate addressof:pixel1 
 766      var Float dist1 := cmc_distance wished got1 c 
 767      if dist1<distance 
 768        memory_copy addressof:pixel1 pixel gamut:pixel_size ; got := got1 ; distance := dist1 
 769        restart improve 
 770   
 771  method gamut try_formulate2 wished pixel using maximum limit l c -> distance 
 772    oarg ColorGamut gamut ; arg ColorXYZ wished ; arg Address pixel ; arg Array:Int using maximum ; arg Int limit ; arg Float distance 
 773    var Int dimension := using size 
 774    distance := cmc_distance wished (gamut simulate pixel) c 
 775    var Int step := 4 
 776    while step>0 
 777      var CBool again := false 
 778      memory_copy pixel addressof:(var ColorBuffer pixel2) gamut:pixel_size 
 779      for (var Int i) 0 3^dimension-1 
 780        part try_one 
 781          memory_copy pixel addressof:(var ColorBuffer pixel1) gamut:pixel_size 
 782          var Int ii := i 
 783          for (var Int dim) dimension-1 
 784            var Int := using dim 
 785            var Int delta := ii%3-1 ; ii \= 3 
 786            if delta<0 
 787              if pixel1:bytes:d<step 
 788                leave try_one 
 789              pixel1:bytes -= step 
 790            eif delta>0 
 791              if pixel1:bytes:d+step>maximum:d 
 792                leave try_one 
 793              pixel1:bytes += step 
 794          if limit=defined 
 795            var Int total := 0 
 796            for (var Int d) gamut:dimension-1 
 797              total += pixel1:bytes d 
 798            if total>limit 
 799              leave try_one 
 800          var Float dist1 := cmc_distance wished (gamut simulate addressof:pixel1) c 
 801          if dist1<distance 
 802            memory_copy addressof:pixel1 addressof:pixel2 gamut:pixel_size ; distance := dist1 
 803            again := true 
 804      memory_copy addressof:pixel2 pixel gamut:pixel_size 
 805      if not again 
 806        step \= 2 
 807   
 808  method gamut fill_pixel using options pixel 
 809    oarg ColorGamutSubstractive gamut ; arg Array:Int using ; arg Str options ; arg Address pixel 
 810    if advanced 
 811      memory_clear pixel gamut:pixel_size 
 812    else 
 813      # for compatibility reasons, but useless 
 814      for (var Int i) 0 gamut:pixel_size-1 
 815        pixel map uInt8 i := options option "start"+string:i Int 0 
 816      for (var Int i) 0 using:size-1 
 817        var Str ink := gamut query "component_name "+(string using:i) 
 818        if (gamut:options option "initial_"+ink) 
 819          pixel map uInt8 using:i := cast (gamut:options option "initial_"+ink Float)*255 Int 
 820   
 821  method gamut do_formulate color options pixel -> distance 
 822    oarg ColorGamutSubstractive gamut ; arg ColorXYZ color ; arg Str options ; arg Address pixel ; arg Float distance 
 823    var Str opt := options+" "+(gamut query "options") 
 824    (var Array:Int maximum) size := gamut dimension 
 825    for (var Int dim) gamut:dimension-1 
 826      if not ((gamut query "component_maximum "+string:dim) parse maximum:dim) 
 827        maximum dim := 255 
 828    var Int limit 
 829    var Float flimit := opt option "limit" Float 
 830    if flimit=defined 
 831      limit := cast flimit*255 Int 
 832    else 
 833      limit := undefined 
 834    var Float := opt option "cmc_l" Float cmc_distance_l_parameter 
 835    var Float := opt option "cmc_c" Float cmc_distance_c_parameter 
 836    var Float epsilon := opt option "epsilon" Float 0.5 
 837    var CBool incremental := opt option "incremental" 
 838    distance := 1e10 
 839    if advanced and not (opt option "conservative") 
 840      part compose 
 841        (var Array:ColorBuffer tests) size := gamut:formulate_using size 
 842        (var Array:Float distances) size := gamut:formulate_using size 
 843        for (var Int i) gamut:formulate_using:size-1 
 844          if incremental 
 845            memory_copy pixel (addressof tests:i) gamut:pixel_size 
 846          else 
 847            gamut fill_pixel gamut:formulate_using:i:using opt (addressof tests:i) 
 848          distances := undefined 
 849        var Float hue := (cast color ColorLCh) h 
 850        var (Index Float Int) combinations 
 851        for (var Int i) gamut:formulate_using:size-1 
 852          if gamut:formulate_using:i:using:size=3 
 853            combinations insert (min (min (abs hue-gamut:formulate_using:i:hue-360) (abs hue-gamut:formulate_using:i:hue)) (abs hue-gamut:formulate_using:i:hue+360)) i 
 854        each ii combinations 
 855          distances ii := gamut try_formulate1 color (addressof tests:ii) gamut:formulate_using:ii:using maximum limit c 
 856          if distances:ii<distance 
 857            memory_copy (addressof tests:ii) pixel gamut:pixel_size ; distance := distances ii 
 858            if distance<epsilon 
 859              leave compose 
 860        var Float mi := opt option "cmc_maximum_improvement" Float (shunt advanced2 20 1e6) 
 861        for (var Int i) gamut:formulate_using:size-1 
 862          if distances:i=undefined or distances:i<distance+mi 
 863            var Float := gamut try_formulate2 color (addressof tests:i) gamut:formulate_using:i:using maximum limit c 
 864            if d<distance 
 865              memory_copy (addressof tests:i) pixel gamut:pixel_size ; distance := d 
 866              if distance<epsilon 
 867                leave compose 
 868    else 
 869      for (var Int i) gamut:formulate_using:size-1 
 870        var ColorBuffer test 
 871        if incremental 
 872          memory_copy pixel addressof:test gamut:pixel_size 
 873        else 
 874          gamut fill_pixel gamut:formulate_using:i:using opt addressof:test 
 875        var Float := gamut try_formulate2 color addressof:test gamut:formulate_using:i:using maximum limit c 
 876        if d<distance 
 877          memory_copy addressof:test pixel gamut:pixel_size ; distance := d 
 878    if (opt option "removal"and gamut:dimension=4 
 879      if not ((opt (opt option_position "removal" 0) opt:len) parse word:"removal" (var Int b0) (var Int b1) any) 
 880        b0 := 0 ; b1 := 0 
 881      var Int black := pixel map uInt8 3 
 882      if black>=b1 
 883        void 
 884      eif black<b0 
 885        black := 0 
 886      else 
 887        black := b1*(black-b0)\(b1-b0) 
 888      (var Array:Int using) size := 3 
 889      using := 0 ; using := 1 ; using := 2 
 890      gamut fill_pixel using opt addressof:(var ColorBuffer test) ; test:bytes := black 
 891      if advanced 
 892        gamut try_formulate1 color addressof:test using maximum limit c 
 893      := gamut try_formulate2 color addressof:test using maximum limit c 
 894      if d<distance or d<epsilon 
 895        memory_copy addressof:test pixel gamut:pixel_size ; distance := d 
 896   
 897  method gamut formulate color options pixel 
 898    oarg ColorGamutSubstractive gamut ; arg ColorXYZ color ; arg Str options ; arg Address pixel 
 899    if verify 
 900      advanced := true 
 901      var Float distance0 := gamut do_formulate color options pixel 
 902      if distance0>0.5 
 903        advanced := false 
 904        var Float distance1 := gamut do_formulate color options pixel 
 905        if distance1-distance0>0.5 
 906          console "color formulation warning: " (string distance0 "fixed 1"" instead of " (string distance1 "fixed 1"", delta is " (string distance0-distance1 "fixed 1") eol 
 907        if distance0-distance1>0.5 
 908          console "color formulation ERROR: " (string distance0 "fixed 1"" instead of " (string distance1 "fixed 1"", delta is " (string distance0-distance1 "fixed 1") eol 
 909    else 
 910      gamut do_formulate color options pixel 
 911   
 912   
 913  method g query question -> answer 
 914    oarg ColorGamutSubstractive g ; arg Str question answer 
 915    if (question parse word:"component_name" (var Int i)) and i>=and i<g:component:size 
 916      answer := g:component:name 
 917    eif (question parse word:"component_maximum" (var Int i)) and i>=and i<g:component:size 
 918      answer := string g:component:i:ink:maximum 
 919    eif (question parse word:"component_options" (var Int i)) and i>=and i<g:component:size 
 920      answer := g:component:i:ink options 
 921    eif question="device" 
 922      answer := device 
 923    eif question="grids" 
 924      answer := "" 
 925      for (var Int i) g:grid:size-1 
 926        answer += (shunt i<>" " "")+g:grid:i:name 
 927    eif question="formulates" 
 928      answer := "" 
 929      for (var Int i) g:formulate_using:size-1 
 930        answer += (shunt i<>" " "") 
 931        for (var Int j) g:formulate_using:i:using:size-1 
 932          answer += (shunt j<>"+" "")+(g:component g:formulate_using:i:using:j):name 
 933    eif question="options" 
 934      answer := options 
 935    eif question="extra" 
 936      answer := extra 
 937    eif question="signature" 
 938      answer := options 
 939      for (var Int i) g:dimension-1 
 940        answer += " "+(string g:component:i:name)+" "+(string g:component:i:ink:options) 
 941    else 
 942      answer := "" 
 943   
 944   
 945 
 
 946  #   building a gamut from name using colors database 
 947   
 948   
 949  function rgb_gamut g name transparency padding reversed options 
 950    arg_rw ColorGamutRGB g ; arg Str name ; arg Int transparency padding ; arg CBool reversed ; arg Str options 
 951    name := name 
 952    pixel_size := 3+transparency+padding 
 953    dimension := 3 
 954    transparency := transparency 
 955    padding := padding 
 956    model := color_gamut_additive 
 957    reversed := reversed 
 958    status := success 
 959    options := options 
 960   
 961  function color_gamut name options -> g 
 962    arg Str name options ; arg Link:ColorGamut g 
 963    var Pointer:Type t 
 964    if (name parse any:(var Str device) ":" any:(var Str inks)) 
 965      :> ColorGamutSubstractive 
 966    eif name="grey" 
 967      :> ColorGamut 
 968    eif name="XYZ" 
 969      :> ColorGamutXYZ 
 970    else 
 971      :> ColorGamutRGB 
 972    plugin extra_types 
 973    if (cache_open "/pliant/color/gamut/"+string:name+options t ((addressof Link:ColorGamut g) map Link:CachePrototype)) 
 974      name := name 
 975      part build 
 976        if t=ColorGamut 
 977          pixel_size := 1 
 978          dimension := 1 
 979          model := color_gamut_additive 
 980          status := success 
 981        eif t=ColorGamutRGB 
 982          var Pointer:ColorGamutRGB ga :> addressof:map ColorGamutRGB 
 983          if name="rgb" 
 984            rgb_gamut ga name 0 0 false options 
 985          eif name="rgb32" 
 986            rgb_gamut ga name 0 1 false options 
 987          eif name="bgr" 
 988            rgb_gamut ga name 0 0 true options 
 989          eif name="bgr32" 
 990            rgb_gamut ga name 0 1 true options 
 991          eif name="rgba" 
 992            rgb_gamut ga name 1 0 false options 
 993          else 
 994            status := failure 
 995        eif t=ColorGamutXYZ 
 996          pixel_size := 3*Float32:size 
 997          dimension := 3 
 998          model := color_gamut_additive 
 999          status := success 
 1000        eif t=ColorGamutSubstractive 
 1001          var Pointer:ColorGamutSubstractive gs :> addressof:map ColorGamutSubstractive 
 1002          gs model := color_gamut_substractive 
 1003          gs device := device 
 1004          gs extra := options 
 1005          gs options := options+(shunt options<>"" and color_database:data:device:device:options<>"" " " "")+color_database:data:device:device:options 
 1006          gs deaden := gs:options option "deaden" Float 0 
 1007          gs no_opacity := gs:options option "no_opacity" 
 1008          inks := replace inks "cmyk" "process_cyan+process_magenta+process_yellow+process_black" ; var Int dim := 0 
 1009          while inks<>"" 
 1010            if not (inks eparse any:(var Str ink) "+" any:(var Str remain)) 
 1011              ink := inks ; remain := "" 
 1012            if ink="transparency" 
 1013              gs transparency := 1 
 1014            eif ink="transparencies" 
 1015              gs multiple_transparency := true 
 1016            else 
 1017              gs:component size := dim+1 
 1018              var Pointer:ColorComponent gc :> gs:component dim 
 1019              gc name := ink 
 1020              if (ink eparse any:(var Str base) "#" any) 
 1021                ink := base 
 1022              gc ink :> color_ink (shunt (ink search ":" -1)=(-1) device+":"+ink ink) options 
 1023              var Int := 0 
 1024              while gc:ink=failure and { var Str device2 := gs:options option "inherit" Str ; device2<>"" } 
 1025                gc ink :> color_ink device2+":"+ink options 
 1026                += 1 
 1027              if gc:ink=failure 
 1028                status := failure (shunt (exists color_database:data:device:device:channel:ink) "Bad" "Unknown")+" '"+ink+"' ink" 
 1029                leave build 
 1030              if (gc:ink:options option "negative") 
 1031                gs negatives += 2^dim 
 1032              dim += 1 
 1033              if (gc:ink:options option "reverse_printing") 
 1034                gs reverse_printing := true 
 1035              if (ink search ":" -1)<>(-1) and (gc:ink:options option "deaden") 
 1036                gs deaden := gc:ink deaden 
 1037            inks := remain 
 1038          if gs:multiple_transparency  
 1039            gs transparency := dim 
 1040          gs dimension := dim 
 1041          gs pixel_size := gs:dimension+gs:transparency 
 1042          if (gs:options option "formulate" Str)<>"" 
 1043            var Int := 0 
 1044            while { var Str inks := gs:options option "formulate" Str ; inks<>"" } 
 1045              += 1 
 1046              part add_combination 
 1047                var ColorFormulateUsing using 
 1048                using:using size := 0 
 1049                while inks<>"" 
 1050                  if not (inks eparse any:(var Str ink) "+" any:(var Str remain)) 
 1051                    ink := inks ; remain := "" 
 1052                  part seach_ink 
 1053                    for (var Int j) gs:dimension-1 
 1054                      if gs:component:j:name=ink 
 1055                        using using += j 
 1056                        leave seach_ink 
 1057                    console "formulate using missing ink " ink eol 
 1058                    leave add_combination 
 1059                  inks := remain 
 1060                using hue := undefined 
 1061                gs formulate_using += using 
 1062          eif gs:dimension>=4 
 1063            var Int darkest := gs:options option "darkest" Int 
 1064            if darkest=undefined 
 1065              darkest := 0 ; var Float Ymini := 1e6 
 1066              for (var Int i) gs:dimension-1 
 1067                var Float := (filter_XYZ gs:component:i:ink:s100/gs:component:i:ink:s0) Y 
 1068                if Y<Ymini 
 1069                  darkest := i ; Ymini := Y 
 1070            var (Index Float Int) hues 
 1071            for (var Int i) gs:dimension-1 
 1072              if i<>darkest and not (gs:component:i:ink:options option "no_formulate") 
 1073                hues insert (cast (filter_XYZ gs:component:i:ink:s100/gs:component:i:ink:s0) ColorLCh):i 
 1074            each hue hues 
 1075              var Pointer:Int hue2 :> hues next hue 
 1076              if not exists:hue2 
 1077                hue2 :> hues first 
 1078              var ColorFormulateUsing using 
 1079              using:using size := 3 
 1080              using:using := darkest 
 1081              using:using := hue 
 1082              using:using := hue2 
 1083              var Float h1 := hues key hue 
 1084              var Float h2 := hues key hue2 
 1085              if h2<h1 
 1086                h2 += 360 
 1087              var Float := (h1+h2)/2 
 1088              if h>=360 
 1089                -= 360 
 1090              using hue := h 
 1091              gs formulate_using += using 
 1092          else 
 1093            gs:formulate_using size := 1 
 1094            gs:formulate_using:0:using size := gs dimension 
 1095            for (var Int i) gs:formulate_using:0:using:size-1 
 1096              gs:formulate_using:0:using := i 
 1097            gs:formulate_using:hue := undefined 
 1098          var Array:FileInfo grids := file_list "data:/pliant/graphic/color/"+device+"/" standard 
 1099          for (var Int i) grids:size-1 
 1100            (var Stream s) open grids:i:name in+safe 
 1101            (var Array:Int indice) size := 0 ; var uInt mask := 0 
 1102            while not s:atend and { var Str := readline ; l<>"" } 
 1103              if (parse word:"ink" (var Str inkname) any:(var Str values)) 
 1104                indice += undefined 
 1105                for (var Int j) gs:dimension-1 
 1106                  if gs:component:j:name=inkname 
 1107                    indice indice:size-:= j 
 1108                if (indice indice:size-1)<>undefined 
 1109                  mask += 2^(indice indice:size-1) 
 1110            if bits_count:mask>=2 
 1111              var ColorGrid grid 
 1112              grid indice := indice 
 1113              grid mask := mask 
 1114              grid name := device+"/"+grids:i:name_without_path 
 1115              gs grid += grid 
 1116          # console "gamut " name " is using " gs:grid:size " grids" eol 
 1117          for (var Int i) gs:grid:size-1 
 1118            gs:grid:simulation :> color_grid_simulation gs:grid:i:name 
 1119            if not (exists gs:grid:i:simulation) 
 1120              status := failure "Corrupted color grid "+gs:grid:i:name 
 1121              leave build 
 1122          gs status := shunt gs:pixel_size<=gamut_maximum_dimension success failure:"Too many components" 
 1123      plugin extra_gamuts 
 1124      if g:status=success 
 1125        cache_ready ((addressof Link:ColorGamut g) map Link:CachePrototype) 
 1126      else 
 1127        cache_cancel ((addressof Link:ColorGamut g) map Link:CachePrototype) 
 1128        var ExtendedStatus status := status 
 1129        :> new ColorGamut 
 1130        status := status 
 1131   
 1132  function color_gamut name -> g 
 1133    arg Str name ; arg Link:ColorGamut g 
 1134    :> color_gamut name "" 
 1135   
 1136  export color_gamut 
 1137   
 1138   
 1139 
 
 1140  #   many components conversions 
 1141   
 1142   
 1143  type ColorPartConversion 
 1144    field Array:Int mapping 
 1145    field Link:ColorGamut gamut 
 1146    field Link:ColorGridConversion grid 
 1147   
 1148  type ColorDirectConversion 
 1149    field Int src 
 1150    field Array:Float dest 
 1151   
 1152  type ColorSplitConversion 
 1153    field Array:ColorDirectConversion direct 
 1154    field Array:ColorPartConversion part 
 1155    field CBool single <- false 
 1156    field CBool opacity <- false 
 1157    field Float limit 
 1158    if hash_conversion 
 1159      field Address cache_buffer <- null 
 1160      field uInt cache_size 
 1161   
 1162  if hash_conversion 
 1163    function destroy conv 
 1164      arg_w ColorSplitConversion conv 
 1165      memory_free conv:cache_buffer 
 1166     
 1167   
 1168  function color_split_conversion src_gamut dest_gamut device grid options -> conv 
 1169    oarg ColorGamut src_gamut dest_gamut ; arg Data:ColorDevice device ; arg ColorGridConversion grid ; arg Str options ; arg Link:ColorSplitConversion conv 
 1170    conv :> new ColorSplitConversion 
 1171    var Str direct_device := (dest_gamut query "options"option "device" Str 
 1172    if direct_device<>"" 
 1173      for (var Int i) src_gamut:dimension-1 
 1174        var Str optionsi := src_gamut query "component_options "+string:i 
 1175        var Int i2 := 0 
 1176        while { var Int pos := optionsi option_position "map" i2 -1 ; pos<>(-1) } 
 1177          if ((optionsi pos optionsi:len) parse word:"map" (var Str dev) (var Str formula) any) 
 1178            if dev=direct_device 
 1179              var ColorDirectConversion direct 
 1180              direct src := i 
 1181              direct:dest size := dest_gamut dimension 
 1182              for (var Int j) dest_gamut:dimension-1 
 1183                direct:dest := formula option (dest_gamut query "component_name "+string:j) Float 0 
 1184              conv direct += direct 
 1185          i2 += 1 
 1186    if exists:grid and conv:direct:size=0 
 1187      var ColorPartConversion part 
 1188      part grid :> grid 
 1189      conv part += part 
 1190      conv single := true 
 1191    else 
 1192      # check (entry_type addressof:src_gamut)=ColorGamutSubstractive 
 1193      for (var Int i) src_gamut:dimension-1 
 1194        var Pointer:ColorInk ink1 :> (addressof:src_gamut map ColorGamutSubstractive):component:ink 
 1195        if ink1:opacity=defined and ink1:opacity>0 
 1196          conv opacity := true 
 1197      var (Dictionary Str Int) component 
 1198      for (var Int i) src_gamut:dimension-1 
 1199        part add_component 
 1200          for (var Int j) conv:direct:size-1 
 1201            if conv:direct:j:src=and not ((src_gamut query "component_options "+string:i) option "visible") 
 1202              leave add_component 
 1203          component insert (src_gamut query "component_name "+string:i) i 
 1204      while component:size>0 
 1205        var Int best_count := 0 ; var Str best_grid ; var Int best_steps 
 1206        if (options option "grid" Str)<>"" 
 1207          var Str all := options option "grid" Str ; var Int count := 0 
 1208          while all<>"" 
 1209            if not (all parse any:(var Str ink) "+" any:(var Str remain)) 
 1210              ink := all ; remain := "" 
 1211            if exists:(component first ink) 
 1212              count += 1 
 1213            all := remain 
 1214          best_count := count ; best_grid := options option "grid" Str ; best_steps := options option "grid_steps" Int undefined 
 1215        if best_count<2 
 1216          each device:grid 
 1217            var Str all := keyof g ; var Int count := 0 
 1218            while all<>"" 
 1219              if not (all parse any:(var Str ink) "+" any:(var Str remain)) 
 1220                ink := all ; remain := "" 
 1221              if exists:(component first ink) 
 1222                count += 1 
 1223              all := remain 
 1224            if count>best_count 
 1225              best_count := count ; best_grid := keyof g ; best_steps := g 
 1226        if best_count>1 
 1227          var ColorPartConversion part 
 1228          part:mapping size := 0 
 1229          var Str all := best_grid 
 1230          while all<>"" 
 1231            if not (all parse any:(var Str ink) "+" any:(var Str remain)) 
 1232              ink := all ; remain := "" 
 1233            if exists:(component first ink) 
 1234              part mapping += component first ink 
 1235              component -= component first ink 
 1236            else 
 1237              part mapping += undefined 
 1238            all := remain 
 1239          part gamut :> color_gamut keyof:device+":"+best_grid "no_opacity" 
 1240          if part:gamut=failure 
 1241            console "Incorrect gamut " keyof:device+":"+best_grid eol 
 1242            conv :> null map ColorSplitConversion 
 1243            return 
 1244          part grid :> color_grid_conversion part:gamut dest_gamut best_steps true 
 1245          conv part += part 
 1246        else 
 1247          each comp component 
 1248            var ColorPartConversion part 
 1249            part:mapping size := 1 
 1250            part:mapping := comp 
 1251            part gamut :> color_gamut keyof:device+":"+(component key comp) "no_opacity" 
 1252            if part:gamut=failure 
 1253              console "Incorrect gamut " keyof:device+":"+(component key comp) eol 
 1254              conv :> null map ColorSplitConversion 
 1255              return 
 1256            part grid :> color_grid_conversion part:gamut dest_gamut undefined true 
 1257            conv part += part 
 1258          component := var (Dictionary Str Int) empty_dict 
 1259    conv limit := (dest_gamut query "options"option "limit" Float 
 1260    if hash_conversion 
 1261      conv cache_size := options option "hash" Int 63541 
 1262      conv cache_buffer := memory_zallocate conv:cache_size*(uInt:size+src_gamut:pixel_size+dest_gamut:pixel_size) addressof:conv 
 1263   
 1264   
 1265  method conv apply src_pixel src_gamut dest_pixel dest_gamut 
 1266    arg_rw ColorSplitConversion conv ; arg Address src_pixel ; oarg ColorGamut src_gamut ; arg Address dest_pixel ; oarg ColorGamut dest_gamut 
 1267    # check (entry_type addressof:src_gamut)=ColorGamutSubstractive 
 1268    if hash_conversion 
 1269      var Int src_psize := src_gamut pixel_size 
 1270      var Int dest_psize := dest_gamut pixel_size 
 1271      var uInt key := 0 
 1272      update_hash_key key src_pixel src_psize 
 1273      key %= conv cache_size 
 1274      var Pointer:uInt sem :> (conv:cache_buffer translate Byte key*(uInt:size+src_psize+dest_psize)) map uInt 
 1275      var Address ptr := addressof:sem translate uInt 1 
 1276      part aquire 
 1277        var uInt := atomic_read_and_set sem 2 
 1278        if u=# cell is defined and not locked 
 1279          if not (memory_different ptr src_psize src_pixel src_psize) 
 1280            memory_copy (ptr translate Byte src_psize) dest_pixel dest_psize 
 1281            sem := 1 
 1282            return 
 1283          sem := 1 
 1284        eif u=# cell is not defined 
 1285          sem := 0 
 1286        else # u=2 : cell is locked 
 1287          os_yield 
 1288          restart aquire 
 1289    if conv:single 
 1290      conv:part:0:grid apply src_pixel src_gamut dest_pixel dest_gamut 
 1291    else 
 1292      var Address ptr0 
 1293      if conv:opacity 
 1294        (addressof:src_gamut map ColorGamutSubstractive) apply_opacity src_pixel addressof:(var ColorBuffer pixel0) 
 1295        ptr0 := addressof pixel0 
 1296      else 
 1297        ptr0 := src_pixel 
 1298      var (Array Float32 gamut_maximum_dimension) result 
 1299      for (var Int j) dest_gamut:dimension-1 
 1300        result := 0 
 1301      if direct_is_linear and conv:direct:size>0 
 1302        src_gamut decode src_pixel (var (Array Float32 gamut_maximum_dimension) f) 
 1303        for (var Int i) conv:direct:size-1 
 1304          var Pointer:ColorDirectConversion direct :> conv:direct i 
 1305          var Float := direct:src 
 1306          if v<>0 
 1307            for (var Int j) direct:dest:size-1 
 1308              result += v*direct:dest:j 
 1309      for (var Int i) conv:part:size-1 
 1310        var Pointer:ColorPartConversion part :> conv:part i 
 1311        var ColorBuffer pixel1 
 1312        for (var Int j) part:mapping:size-1 
 1313          if part:mapping:j=defined 
 1314            addressof:pixel1 map uInt8 := ptr0 map uInt8 part:mapping:j 
 1315          else 
 1316            addressof:pixel1 map uInt8 := 0 
 1317        var ColorBuffer pixel2 
 1318        conv:part:i:grid apply addressof:pixel1 part:gamut addressof:pixel2 dest_gamut 
 1319        dest_gamut decode addressof:pixel2 (var (Array Float32 gamut_maximum_dimension) f) 
 1320        for (var Int j) dest_gamut:dimension-1 
 1321          result += f:j*(1-result:j) 
 1322      if conv:limit=defined 
 1323        var Float total := 0 
 1324        for (var Int j) dest_gamut:dimension-1 
 1325          total += result j 
 1326        if total>conv:limit 
 1327          var Float remove := (total-conv:limit)/(shunt dest_gamut:dimension>dest_gamut:dimension-dest_gamut:dimension) 
 1328          for (var Int j) dest_gamut:dimension-1 
 1329            if j<># leave black unmodified 
 1330              result -= remove 
 1331      dest_gamut encode result dest_pixel 
 1332      if not direct_is_linear 
 1333        for (var Int i) 0 conv:direct:size-1 
 1334          var Pointer:ColorDirectConversion direct :> conv:direct i 
 1335          var Int v := src_pixel map uInt8 direct:src 
 1336          if v<>0 
 1337            for (var Int j) 0 direct:dest:size-1 
 1338              var Float w := direct:dest j 
 1339              if w<>0 
 1340                dest_pixel map uInt8 j := min (cast (dest_pixel map uInt8 j) + v*w Int) 255 
 1341    if hash_conversion 
 1342      part lock 
 1343        var uInt := atomic_read_and_set sem 2 
 1344        if u=2 
 1345          os_yield 
 1346          restart lock 
 1347      memory_copy src_pixel ptr src_psize 
 1348      memory_copy dest_pixel (ptr translate Byte src_psize) dest_psize 
 1349      sem := 1 
 1350   
 1351   
 1352 
 
 1353  #   to additive advanced conversion 
 1354   
 1355   
 1356  method g speedup src_gamut options -> speedup 
 1357    oarg ColorGamutRGB src_gamut ; arg Str options ; arg Arrow speedup 
 1358    if (entry_type addressof:src_gamut)=ColorGamutSubstractive and (options option "fast") 
 1359      speedup := addressof void 
 1360    eif src_gamut:model=color_gamut_additive and g:options<>"" 
 1361      var Link:ColorGridConversion gconv :> new ColorGridConversion 
 1362      gconv compute src_gamut g (min (max (g:options option "grid_steps" Int 17) 5) 65) false false 
 1363      if hash_rgb 
 1364        var Link:ColorSplitConversion sconv :> color_split_conversion src_gamut g (var Data:ColorDevice device) gconv options 
 1365        speedup := addressof sconv 
 1366      else 
 1367        speedup := addressof gconv 
 1368    else 
 1369      speedup := null 
 1370   
 1371   
 1372  method dest_gamut convert src_gamut src_pixels dest_pixels count speedup 
 1373    oarg ColorGamutRGB dest_gamut ; oarg ColorGamut src_gamut ; arg Address src_pixels dest_pixels ; arg Int count ; arg Address speedup 
 1374    if speedup<>null 
 1375      if entry_type:speedup=Void 
 1376        var Link:ColorGamutSubstractive :> addressof:src_gamut map ColorGamutSubstractive 
 1377        var Address := src_pixels ; var Int src_psize := src_gamut pixel_size 
 1378        var Address stop := src_pixels translate Byte count*g:pixel_size 
 1379        var Address := dest_pixels ; var Int dest_psize := dest_gamut pixel_size 
 1380        while s<>stop 
 1381          if s<>src_pixels and not (memory_different src_psize (translate Byte -src_psize) src_psize) 
 1382            memory_copy (translate Byte -dest_psize) dest_psize 
 1383          else 
 1384            (var ColorFast cf) init 
 1385            if g:reverse_printing 
 1386              for (var Int i) g:dimension-1 0 step -1 
 1387                cf apply g:component:i:ink (map uInt8 i) 
 1388            else 
 1389              for (var Int i) g:dimension-1 
 1390                cf apply g:component:i:ink (map uInt8 i) 
 1391            cf terminate (map ColorRGB888) 
 1392          := translate Byte src_psize ; := translate Byte dest_psize 
 1393        transparency_convert src_pixels src_gamut dest_pixels dest_gamut count 
 1394      eif entry_type:speedup=ColorGridConversion 
 1395        var Link:ColorGridConversion gconv :> speedup map ColorGridConversion 
 1396        var Address := src_pixels ; var Int src_psize := src_gamut pixel_size 
 1397        var Address stop := src_pixels translate Byte count*src_psize 
 1398        var Address := dest_pixels ; var Int dest_psize := dest_gamut pixel_size 
 1399        while s<>stop 
 1400          if s<>src_pixels and not (memory_different src_psize (translate Byte -src_psize) src_psize) 
 1401            memory_copy (translate Byte -dest_psize) dest_psize 
 1402          else 
 1403            gconv apply src_gamut dest_gamut 
 1404          := translate Byte src_psize ; := translate Byte dest_psize 
 1405        transparency_convert src_pixels src_gamut dest_pixels dest_gamut count 
 1406      eif entry_type:speedup=ColorSplitConversion 
 1407        var Link:ColorSplitConversion sconv :> speedup map ColorSplitConversion 
 1408        var Address := src_pixels ; var Int src_psize := src_gamut pixel_size 
 1409        var Address stop := src_pixels translate Byte count*src_psize 
 1410        var Address := dest_pixels ; var Int dest_psize := dest_gamut pixel_size 
 1411        while s<>stop 
 1412          if s<>src_pixels and not (memory_different src_psize (translate Byte -src_psize) src_psize) 
 1413            memory_copy (translate Byte -dest_psize) dest_psize 
 1414          else 
 1415            sconv apply src_gamut dest_gamut 
 1416          := translate Byte src_psize ; := translate Byte dest_psize 
 1417        transparency_convert src_pixels src_gamut dest_pixels dest_gamut count 
 1418    eif src_gamut:model=color_gamut_additive 
 1419      var CBool src_gamut_reversed := (addressof:src_gamut map ColorGamutRGB) reversed 
 1420      if dest_gamut:pixel_size=src_gamut:pixel_size and dest_gamut:reversed=src_gamut_reversed 
 1421        memory_copy src_pixels dest_pixels count*dest_gamut:pixel_size 
 1422      else 
 1423        if dest_gamut:pixel_size=1 
 1424          bytes_copy (src_pixels translate uInt8 src_gamut:dimension\2) src_gamut:pixel_size dest_pixels dest_gamut:pixel_size count 
 1425        eif src_gamut:pixel_size=1 
 1426          for (var Int c) 0 2 
 1427            bytes_copy src_pixels src_gamut:pixel_size (dest_pixels translate uInt8 c) dest_gamut:pixel_size count 
 1428        eif dest_gamut:reversed=src_gamut_reversed 
 1429          bytes_copy24 src_pixels src_gamut:pixel_size dest_pixels dest_gamut:pixel_size count 
 1430        else 
 1431          for (var Int c) 0 2 
 1432            bytes_copy (src_pixels translate uInt8 2-c) src_gamut:pixel_size (dest_pixels translate uInt8 c) dest_gamut:pixel_size count 
 1433        if dest_gamut:transparency=and src_gamut:transparency=1 
 1434          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 
 1435        eif dest_gamut:transparency=1 
 1436          bytes_fill (dest_pixels translate uInt8 dest_gamut:dimension) dest_gamut:pixel_size count 
 1437    else 
 1438      default_convert src_pixels src_gamut dest_pixels dest_gamut count 
 1439   
 1440   
 1441 
 
 1442  #   to substractive advanced conversion 
 1443   
 1444   
 1445  gvar Sem fast_simulation_sem 
 1446   
 1447  method g speedup src_gamut options -> speedup 
 1448    oarg ColorGamutSubstractive g ; oarg ColorGamut src_gamut ; arg Str options ; arg Arrow speedup 
 1449    part setup "color conversion speedup "+src_gamut:name+" -> "+g:name+" with options "+options 
 1450      var Data:ColorDevice device 
 1451      if (entry_type addressof:src_gamut)=ColorGamutSubstractive 
 1452        device :> color_database:data:device (addressof:src_gamut map ColorGamutSubstractive):device 
 1453      if (entry_type addressof:src_gamut)=ColorGamutSubstractive and { var Link:ColorGamutSubstractive src_g :> addressof:src_gamut map ColorGamutSubstractive ; src_g:device=g:device } 
 1454        var (Link Array:Int) mapping :> new Array:Int 
 1455        for (var Int i) src_g:dimension-1 
 1456          part map_component 
 1457            for (var Int j) g:dimension-1 
 1458              if src_g:component:i:name=g:component:j:name 
 1459                mapping += i ; mapping += j 
 1460                leave map_component 
 1461        speedup := addressof mapping 
 1462      else 
 1463        fast_simulation_sem request 
 1464        if (options option "hurry"and not (exists g:fast_simulation) and g:dimension<=4 
 1465          (addressof:omap ColorGamutSubstractive) another_gamut :> color_gamut g:name g:options+" another" 
 1466          (addressof:omap ColorGamutSubstractive) xyz_gamut :> color_gamut "XYZ" 
 1467          (addressof:omap ColorGamutSubstractive) fast_simulation :> color_grid_conversion g:another_gamut g:xyz_gamut (options option "hurry" Int 33) false 
 1468        fast_simulation_sem release 
 1469        if device:grid:size>0 
 1470          var Link:ColorSplitConversion sconv :> color_split_conversion src_gamut device (null map ColorGridConversion) options 
 1471          speedup := addressof sconv 
 1472        else 
 1473          var Link:ColorGridConversion gconv :> color_grid_conversion src_gamut g (options option "grid_steps" Int) true 
 1474          if hash_rgb 
 1475            var Link:ColorSplitConversion sconv :> color_split_conversion src_gamut device gconv options 
 1476            speedup := addressof sconv 
 1477          else 
 1478            speedup := addressof gconv 
 1479   
 1480  method dest_gamut convert src_gamut src_pixels dest_pixels count speedup 
 1481    oarg ColorGamutSubstractive dest_gamut ; oarg ColorGamut src_gamut ; arg Address src_pixels dest_pixels ; arg Int count ; arg Address speedup 
 1482    if speedup<>null and entry_type:speedup=Array:Int 
 1483      memory_clear dest_pixels count*dest_gamut:pixel_size 
 1484      if src_gamut:transparency=and not (addressof:src_gamut map ColorGamutSubstractive):multiple_transparency 
 1485        transparency_convert src_pixels src_gamut dest_pixels dest_gamut count 
 1486      var (Pointer Array:Int) mapping :> speedup map Array:Int 
 1487      for (var Int u) mapping:size-2 step 2 
 1488        var Int := mapping u ; var Int := mapping u+1 
 1489        bytes_copy (src_pixels translate Byte i) src_gamut:pixel_size (dest_pixels translate Byte j) dest_gamut:pixel_size count 
 1490        if i<src_gamut:transparency and j<dest_gamut:transparency 
 1491          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 
 1492        eif src_gamut:transparency=and j<dest_gamut:transparency 
 1493          bytes_fill (dest_pixels translate Byte dest_gamut:dimension+j) dest_gamut:pixel_size count 
 1494    eif speedup<>null and entry_type:speedup=ColorGridConversion 
 1495      var Link:ColorGridConversion gconv :> speedup map ColorGridConversion 
 1496      var Address := src_pixels ; var Int src_psize := src_gamut pixel_size 
 1497      var Address stop := src_pixels translate Byte count*src_psize 
 1498      var Address := dest_pixels ; var Int dest_psize := dest_gamut pixel_size 
 1499      while s<>stop 
 1500        if s<>src_pixels and not (memory_different src_psize (translate Byte -src_psize) src_psize) 
 1501          memory_copy (translate Byte -dest_psize) dest_psize 
 1502        else 
 1503          gconv apply src_gamut dest_gamut 
 1504        := translate Byte src_psize ; := translate Byte dest_psize 
 1505      transparency_convert src_pixels src_gamut dest_pixels dest_gamut count 
 1506    eif speedup<>null and entry_type:speedup=ColorSplitConversion 
 1507      var Link:ColorSplitConversion sconv :> speedup map ColorSplitConversion 
 1508      var Address := src_pixels ; var Int src_psize := src_gamut pixel_size 
 1509      var Address stop := src_pixels translate Byte count*src_psize 
 1510      var Address := dest_pixels ; var Int dest_psize := dest_gamut pixel_size 
 1511      while s<>stop 
 1512        if s<>src_pixels and not (memory_different src_psize (translate Byte -src_psize) src_psize) 
 1513          memory_copy (translate Byte -dest_psize) dest_psize 
 1514        else 
 1515          sconv apply src_gamut dest_gamut 
 1516        := translate Byte src_psize ; := translate Byte dest_psize 
 1517      transparency_convert src_pixels src_gamut dest_pixels dest_gamut count 
 1518    else 
 1519      default_convert src_pixels src_gamut dest_pixels dest_gamut count 
 1520   
 1521   
 1522 
 
 1523  #   Pre compute a color conversion 
 1524   
 1525   
 1526  function color_gamut_compute src_gamut_name dest_gamut_name options timeout -> status 
 1527    arg Str src_gamut_name dest_gamut_name ; arg Str options ; arg Float timeout ; arg ExtendedStatus status 
 1528    var DateTime startup := datetime 
 1529    var Link:ColorGamut src :> color_gamut src_gamut_name 
 1530    var Link:ColorGamut dest :> color_gamut dest_gamut_name 
 1531    if src=failure 
 1532      return src 
 1533    if dest=failure 
 1534      return dest 
 1535    var Arrow speedup := dest speedup src options 
 1536    var Int := max (cast 2^20^(1/src:dimension) Int) 2 
 1537    var Int step := max 255\(i-1) 1 
 1538    var Int total := i^src:dimension 
 1539    memory_clear addressof:(var ColorBuffer src_pixel) src:pixel_size 
 1540    var Int count := 0 
 1541    part compute "Pre computing gamut "+dest_gamut_name 
 1542      part node "computing node "+string:count+"/"+string:total+"  ("+(string 100*count\total)+"% in "+(string datetime:seconds-startup:seconds "fixed 0")+" seconds)" 
 1543        dest convert src addressof:src_pixel addressof:(var ColorBuffer dest_pixel) speedup 
 1544      var Int := src:dimension-1 
 1545      while (addressof:src_pixel map uInt8 i)+step>255 
 1546        if i=0 
 1547          leave compute 
 1548        -= 1 
 1549      addressof:src_pixel map uInt8 += step 
 1550      += 1 
 1551      while i<src:dimension 
 1552        addressof:src_pixel map uInt8 := 0 
 1553        += 1 
 1554      count += 1 
 1555      if timeout=defined and datetime:seconds-startup:seconds>=timeout 
 1556        return failure:"timeout" 
 1557      restart compute 
 1558    status := success 
 1559   
 1560  # color_gamut_compute "pantone:process_cyan+process_magenta+process_yellow+process_black" "iris_heliosam2:cyan+magenta+yellow+black" 21600 
 1561   
 1562   
 1563 
 
 1564  #   Gimp-print calibration profile generator 
 1565   
 1566   
 1567  method conv dump filename src_gamut dest_gamut 
 1568    arg_rw ColorGridConversion conv ; arg Str filename ; oarg ColorGamut src_gamut dest_gamut 
 1569    implicit conv 
 1570      check mapping:size=steps^dim*dest_gamut:dimension 
 1571      for (var Int i) steps^dim-1 
 1572        conv compute_node src_gamut dest_gamut 
 1573        console "computing color profile ("+(string i*100\steps^dim)+"%)   [cr]" 
 1574      (var Stream s) open filename out+safe 
 1575      writeline "Pliant calibration profile for Gimp-print" 
 1576      writeline "pliant_release "+(string pliant_release_number) 
 1577      writeline "source_gamut "+(string src_gamut:name) 
 1578      writechars "source_sampling" 
 1579      for (var Int i) steps-1 
 1580        writechars " "+(string i*255\(steps-1)) 
 1581      writeline "" 
 1582      writeline "destination_gamut "+(string dest_gamut:name) 
 1583      writeline "destination_maximum 65535" # assuming Gimp-print CMYK16 
 1584      writeline "" 
 1585      for (var Int i) steps^dim-1 
 1586        for (var Int d) dim-1 
 1587          var Int := i\(steps^d)%steps 
 1588          := l*255\(steps-1) 
 1589          writechars (shunt d="" " ")+string:l 
 1590        writechars " :" 
 1591        var Pointer:(Array Float32 gamut_maximum_dimension) result :> (addressof:(mapping i*dest_gamut:dimension) map (Array Float32 gamut_maximum_dimension)) 
 1592        dest_gamut encode result addressof:(var ColorBuffer pixel) 
 1593        for (var Int d) dest_gamut:dimension-1 
 1594          var Int := pixel:bytes d 
 1595          := l*l+2*l 
 1596          writechars " "+string:l 
 1597        writeline "" 
 1598      console (repeat 60 " ") eol 
 1599   
 1600   
 1601  function color_gamut_profile src_gamut_name dest_gamut_name filename steps 
 1602    arg Str src_gamut_name dest_gamut_name filename ; arg Int steps 
 1603    var Link:ColorGamut src_gamut :> color_gamut src_gamut_name 
 1604    var Link:ColorGamut dest_gamut :> color_gamut dest_gamut_name 
 1605    var Link:ColorGridConversion conv :> new ColorGridConversion  
 1606    var Int dim := src_gamut:dimension 
 1607    var Int default_steps := shunt dim<=and src_gamut:model=color_gamut_additive 33 dim<=4 17 dim<=6 9 5 
 1608    conv compute src_gamut dest_gamut (shunt steps=defined steps default_steps) true true 
 1609    conv dump filename src_gamut dest_gamut 
 1610   
 1611  function color_gamut_profile src_gamut_name dest_gamut_name filename 
 1612    arg Str src_gamut_name dest_gamut_name filename 
 1613    color_gamut_profile src_gamut_name dest_gamut_name filename undefined 
 1614   
 1615  export color_gamut_compute color_gamut_profile