Patch title: Release 94 bulk changes
Abstract:
File: /pliant/graphic/image/lut.pli
Key:
    Removed line
    Added line
   
module "/pliant/language/compiler.pli"
submodule "prototype.pli"
module "/pliant/language/compiler/type/inherit.pli"
module "/pliant/math/curve.pli"
module "/pliant/graphic/color/gamut.pli"
module "/pliant/graphic/color/spectrum.pli" # defines 'expos
module "/pliant/graphic/misc/int.pli"
module "/pliant/graphic/misc/mtbuffer.pli"


type ImageLut
  inherit ImagePrototype
  field Link:ImagePrototype image
  field MtBuffer buffers
module "/pliant/language/compiler.pli"
submodule "prototype.pli"
module "/pliant/language/compiler/type/inherit.pli"
module "/pliant/math/curve.pli"
module "/pliant/graphic/color/gamut.pli"
module "/pliant/graphic/color/spectrum.pli" # defines 'expos
module "/pliant/graphic/misc/int.pli"
module "/pliant/graphic/misc/mtbuffer.pli"


type ImageLut
  inherit ImagePrototype
  field Link:ImagePrototype image
  field MtBuffer buffers
  field Array:(Array Float32 256) gradation
  field Array:(Array Float32 256) lut
  field Array:(Array uInt8 256) lut8
  field Array:Float32 remain
  field Float maxi
  field uInt random_bits ; field Int random_available
  field Array:Float32 remain
  field Float maxi
  field uInt random_bits ; field Int random_available
  field CBool fast <- false


method l compute image
  arg_rw ImageLut l ; oarg ImagePrototype image
  addressof:l map ImagePrototype := addressof:image map Imag
  l image :> image
  l:buffers size := image line_size
  l:remain size := l:line_size+l:gamut:pixel_size
  for (var Int i) 0 l:remain:size-1
    l:remain i := 0
  l maxi := 0


method l compute image
  arg_rw ImageLut l ; oarg ImagePrototype image
  addressof:l map ImagePrototype := addressof:image map Imag
  l image :> image
  l:buffers size := image line_size
  l:remain size := l:line_size+l:gamut:pixel_size
  for (var Int i) 0 l:remain:size-1
    l:remain i := 0
  l maxi := 0
  for (var Int d) 0 l:gradation:size-1
  for (var Int d) 0 l:lut:size-1
    for (var Int i) 0 254
    for (var Int i) 0 254
      l maxi := max l:maxi (l:gradation:d i+1)-(l:gradation:
      l maxi := max l:maxi (l:lut:d i+1)-(l:lut:d i)
  l random_available := 0

method l bind image options -> status
  arg_rw ImageLut l ; oarg ImagePrototype image ; arg Str op
  l random_available := 0

method l bind image options -> status
  arg_rw ImageLut l ; oarg ImagePrototype image ; arg Str op
  l:gradation size := image:gamut dimension
  for (var Int d) 0 l:gradation:size-1
  l:lut size := image:gamut dimension
  l:lut8 size := image:gamut dimension
  for (var Int d) 0 l:lut:size-1
    var Float middle := options option (image:gamut query "component_name "+string:d)+"_middle" Float (options option "middle" Float)
    var Float density := options option (image:gamut query "component_name "+string:d)+"_density" Float (options option "density" Float)
    var Float exposure := options option "exposure"+string:d
    var Float multiply := options option "multiply"+string:d
    var Float add := options option "add"+string:d Float (op
    var Float minimum := options option "minimum"+string:d F
    var Float maximum := options option "maximum"+string:d F
    var Float exposure := options option "exposure"+string:d
    var Float multiply := options option "multiply"+string:d
    var Float add := options option "add"+string:d Float (op
    var Float minimum := options option "minimum"+string:d F
    var Float maximum := options option "maximum"+string:d F
    if not ((options (options option_position "cut" 0) options:len) parse word:"cut" (var Float cut0) (var Float cut1) any)
      cut0 := undefined ; cut1 := undefined
    for (var Int i) 0 255
      var Float f := i/255
    for (var Int i) 0 255
      var Float f := i/255
      if middle=defined
        f := exposure f middle
      if density=defined
        f *= density
      if exposure=defined
        f := exposure f exposure
      if multiply=defined
        f *= multiply
      if add=defined
        f += add
      if minimum=defined
        f := min f minimum
      if maximum=defined
        f := max f maximum
      if exposure=defined
        f := exposure f exposure
      if multiply=defined
        f *= multiply
      if add=defined
        f += add
      if minimum=defined
        f := min f minimum
      if maximum=defined
        f := max f maximum
      l:gradation:d i := f*255
      if cut0=defined
        f := shunt f<=cut0 0 f<=cut1 cut1/(cut1-cut0)*(f-cut0) f
      l:lut:d i := f*255
      l:lut8:d i := cast f*255 Int
  l fast := options option "fast"
  l compute image
  status := success

method l bind image curve range_x range_y options -> status
  arg_rw ImageLut l ; oarg ImagePrototype image ; arg Curve 
  l compute image
  status := success

method l bind image curve range_x range_y options -> status
  arg_rw ImageLut l ; oarg ImagePrototype image ; arg Curve 
  l:gradation size := image:gamut dimension
  for (var Int d) 0 l:gradation:size-1
  l:lut size := image:gamut dimension
  for (var Int d) 0 l:lut:size-1
    for (var Int i) 0 255
      if (options option "invert")
    for (var Int i) 0 255
      if (options option "invert")
        l:gradation:d i := (curve x i/255*range_y 1e-6)/rang
        l:lut:d i := (curve x i/255*range_y 1e-6)/range_x*255
      else
      else
        l:gradation:d i := (curve y i/255*range_x 1e-6)/rang
        l:lut:d i := (curve y i/255*range_x 1e-6)/range_y*255
  l compute image
  if buggy
    if (options option "monotonous")
      for (var Int i) 0 999
        if (curve x_param (i+1)/1000)<=(curve x_param i/1000
  l compute image
  if buggy
    if (options option "monotonous")
      for (var Int i) 0 999
        if (curve x_param (i+1)/1000)<=(curve x_param i/1000
          return failure:"Gradation curve is buggy"
          return failure:"lut curve is buggy"
        if (curve y_param (i+1)/1000)<=(curve y_param i/1000
        if (curve y_param (i+1)/1000)<=(curve y_param i/1000
          return failure:"Gradation curve is buggy"
      for (var Int d) 0 l:gradation:size-1
          return failure:"lut curve is buggy"
      for (var Int d) 0 l:lut:size-1
        for (var Int i) 0 255
        for (var Int i) 0 255
          if (l:gradation:d i)=undefined
            return failure:"Gradation is not properly define
          if (l:gradation:d i)<(-0.1) or (l:gradation:d i)>2
            return failure:"Gradation is out of range"
          if (l:lut:d i)=undefined
            return failure:"lut is not properly defined"
          if (l:lut:d i)<(-0.1) or (l:lut:d i)>255.1
            return failure:"lut is out of range"
        for (var Int i) 0 254
        for (var Int i) 0 254
          if (l:gradation:d i+1)<=(l:gradation:d i)
            return failure:"Gradation is not monotonous"
          if (l:lut:d i+1)<=(l:lut:d i)
            return failure:"lut is not monotonous"
      if l:maxi=undefined or l:maxi<0 or l:maxi>255
      if l:maxi=undefined or l:maxi<0 or l:maxi>255
        return failure:"Maximum gradation step is out of ran
        return failure:"Maximum lut step is out of range"
  status := success

  status := success

method l bind image lut -> status
  arg_rw ImageLut l ; oarg ImagePrototype image ; arg Array:(Array Float32 256) lut ; arg ExtendedStatus status
  l lut := lut
  l compute image
  status := success



method l read x y count adr
  oarg_rw ImageLut l ; arg Int x y count ; arg Address adr
  var Int dim := l:gamut dimension
  var Int psize := l pixel_size
method l read x y count adr
  oarg_rw ImageLut l ; arg Int x y count ; arg Address adr
  var Int dim := l:gamut dimension
  var Int psize := l pixel_size
  check l:gradation:size=dim
  check l:lut:size=dim
  var Address buffer := l:buffers allocate
  l:image read x y count buffer
  var Address src := buffer
  var Address stop := src translate uInt8 count*psize
  var Address dest := adr
  var Address buffer := l:buffers allocate
  l:image read x y count buffer
  var Address src := buffer
  var Address stop := src translate uInt8 count*psize
  var Address dest := adr
  var (Pointer Array:(Array Float32 256)) gradation :> l gra
  var Pointer:Float32 remain :> l:remain x*psize
  var Float maxi := l maxi
  var uInt bits := l random_bits ; var Int available := l ra
  while src<>stop
    for (var Int i) 0 dim-1
      var Pointer:(Array Float32 256) g :> gradation i
      var Float f := remain+g:(src map uInt8)
      var Int v := bound (cast f Int) 0 255
      dest map uInt8 := v
      f -= v
      if f<(-maxi)
        f := -maxi
      if f>maxi
        f := maxi
      if available=0
        memory_random addressof:bits uInt:size
        available := uInt:size*8
      if (bits .and. 1)<>0 # send to the right
        remain := 0
        addressof:remain map Float32 psize += f
      else # send to the bottom
        remain := f
      bits := bits\2 ; available -= 1
      src := src translate uInt8 1
      dest := dest translate uInt8 1
      remain :> addressof:remain map Float32 1
    if psize>dim
      memory_copy src dest psize-dim
      src := src translate uInt8 psize-dim
      dest := dest translate uInt8 psize-dim
      remain :> addressof:remain map Float32 psize-dim
  l random_bits := bits
  l random_available := available
  if l:fast
    var (Pointer Array:(Array uInt8 256)) lut8 :> l lut8
    while src<>stop
      for (var Int i) 0 dim-1
        dest map uInt8 := lut8:i (src map uInt8)
        src := src translate uInt8 1
        dest := dest translate uInt8 1
      if psize>dim
        memory_copy src dest psize-dim
        src := src translate uInt8 psize-dim
        dest := dest translate uInt8 psize-dim
  else
    var (Pointer Array:(Array Float32 256)) lut :> l lut
    var Pointer:Float32 remain :> l:remain x*psize
    var Float maxi := l maxi
    var uInt bits := l random_bits ; var Int available := l random_available
    while src<>stop
      for (var Int i) 0 dim-1
        var Pointer:(Array Float32 256) g :> lut i
        var Float f := remain+g:(src map uInt8)
        var Int v := bound (cast f Int) 0 255
        dest map uInt8 := v
        f -= v
        if f<(-maxi)
          f := -maxi
        if f>maxi
          f := maxi
        if available=0
          memory_random addressof:bits uInt:size
          available := uInt:size*8
        if (bits .and. 1)<>0 # send to the right
          remain := 0
          addressof:remain map Float32 psize += f
        else # send to the bottom
          remain := f
        bits := bits\2 ; available -= 1
        src := src translate uInt8 1
        dest := dest translate uInt8 1
        remain :> addressof:remain map Float32 1
      if psize>dim
        memory_copy src dest psize-dim
        src := src translate uInt8 psize-dim
        dest := dest translate uInt8 psize-dim
        remain :> addressof:remain map Float32 psize-dim
    l random_bits := bits
    l random_available := available
  l:buffers free buffer



  l:buffers free buffer