Patch title: Release 94 bulk changes
Abstract:
File: /pliant/graphic/image/prototype.pli
Key:
    Removed line
    Added line
abstract
  ['ImagePrototype' is defining the API to deal with pixels in a Pliant image.]

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

module "/pliant/language/compiler.pli"
module "/pliant/graphic/color/gamut.pli"

constant optimize true


public


type ImagePrototype
  field Int size_x size_y pixel_size
  field Link:ColorGamut gamut
  field Float x0 y0 x1 y1
  field Str options


method p setup proto options -> status
  oarg_rw ImagePrototype p ; arg ImagePrototype proto ; arg Str options ; arg ExtendedStatus status
  generic
  status := failure "unsupported"

method p read x y count adr
  oarg_rw ImagePrototype p ; arg Int x y count ; arg Address adr
  generic
  error error_id_missing "Not implemented for "+(entry_type addressof:p):name

method p write x y count adr
  oarg_rw ImagePrototype p ; arg Int x y count ; arg Address adr
  generic
  error error_id_missing "Not implemented for "+(entry_type addressof:p):name

method p read_map x y mini maxi count -> adr
  oarg_rw ImagePrototype p ; arg Int x y mini maxi ; arg_w Int count ; arg Address adr
  generic
  count := 0 ; adr := null

method p read_unmap x y count adr
  oarg_rw ImagePrototype p ; arg Int x y count ; arg Address adr
  generic

method p write_map x y mini maxi count -> adr
  oarg_rw ImagePrototype p ; arg Int x y mini maxi ; arg_w Int count ; arg Address adr
  generic
  count := 0 ; adr := null

method p write_unmap x y count adr
  oarg_rw ImagePrototype p ; arg Int x y count ; arg Address adr
  generic

method p fill x y count pixel
  oarg_rw ImagePrototype p ; arg Int x y count ; arg Address pixel
  generic
  check count>0 and x>=0 and x+count<=p:size_x and y>=0 and y<p:size_y
  function fill buf count psize pixel
    arg Address buf ; arg Int count psize ; arg Address pixel
    if optimize and psize=1
      var uInt color := pixel map uInt8 ; color := color+color*2^8
      fill buf count\2 2 addressof:color
      if count%2=1
        buf map uInt8 count-1 := pixel map uInt8
    eif optimize and psize=2
      var uInt color := pixel map uInt16 ; color := color+color*2^16
      fill buf count\2 4 addressof:color
      if count%2=1
        buf map uInt16 count-1 := pixel map uInt16
    eif optimize and psize=3
      var uInt color := pixel map uInt32
      var Address dest := buf ; var Address stop := dest translate Byte (count-1)*3
      while dest<>stop
        dest map uInt32 := color
        dest := dest translate Byte psize
      memory_copy pixel dest psize
    eif optimize and psize=4
      var uInt color := pixel map uInt32
      var Address dest := buf ; var Address stop := dest translate uInt32 count
      while dest<>stop
        dest map uInt32 := color
        dest := dest translate uInt32
    else
      var Address dest := buf ; var Address stop := dest translate Byte count*psize
      while dest<>stop
        memory_copy pixel dest psize
        dest := dest translate Byte psize
  var Int done := 0
  while done<count
    var Address start := p write_map x+done y 1 count-done (var Int step)
    if start<>null
      fill start step p:pixel_size pixel
      p write_unmap x+done y step start
      done += step
    else
      var Address buf := memory_allocate (count-done)*p:pixel_size null
      fill buf count-done p:pixel_size pixel
      p write x+done y count-done buf
      memory_free buf
      done := count


method p clip x0 y0 x1 y1
  oarg ImagePrototype p ; arg_rw Int x0 y0 x1 y1
  generic
  x0 := max x0 0
  y0 := max y0 0
  x1 := min x1 p:size_x
  y1 := min y1 p:size_y


method p rectangle_read_map x y x0 y0 x1 y1 step_x step_y -> adr
  oarg_rw ImagePrototype p ; arg Int x y ; arg_w Int x0 y0 x1 y1 step_x step_y ; arg Address adr
  generic
  adr := p read_map x y 1 p:size_x-x (var Int count)
  if adr<>null
    x0 := x ; y0 := y ; x1 := x+count ; y1 := y+1
    step_x := p pixel_size ; step_y := undefined

method p rectangle_read_unmap x0 y0 x1 y1 adr
  oarg_rw ImagePrototype p ; arg Int x0 y0 x1 y1 ; arg Address adr
  generic


method p query command -> answer
  oarg_rw ImagePrototype p ; arg Str command answer
  generic
  answer := ""

method p configure command -> status
  oarg_rw ImagePrototype p ; arg Str command ; arg ExtendedStatus status
  generic
  status := failure "unkown command"


method p line_size -> ls
  arg ImagePrototype p ; arg Int ls
  ls := p:pixel_size*p:size_x


method p complete
  arg_rw ImagePrototype p
  p pixel_size := p:gamut pixel_size

function image_prototype x0 y0 x1 y1 size_x size_y gamut -> p
  arg Float x0 y0 x1 y1 ; arg Int size_x size_y ; oarg ColorGamut gamut ; arg ImagePrototype p
  check exists:gamut
  p size_x := size_x
  p size_y := size_y
  p gamut :> gamut
  p x0 := x0
  p y0 := y0
  p x1 := x1
  p y1 := y1
  p options := ""
  p complete

constant image_adjust_extend 1001
constant image_adjust_reduce 1002
constant image_adjust_resolution 1003

function image_prototype x0 y0 x1 y1 rx ry aa_x aa_y adjust gamut -> p
  arg Float x0 y0 x1 y1 rx ry ; arg Int aa_x aa_y adjust ; oarg ColorGamut gamut ; arg ImagePrototype p
  check adjust>=image_adjust_extend and adjust<=image_adjust_resolution
  var Int size_x := (max (cast (abs x1-x0)*(rx/25.4)/aa_x+(shunt adjust=image_adjust_extend 0.5 adjust=image_adjust_reduce -0.5 0) Int) 1)*aa_x
  var Int size_y := (max (cast (abs y1-y0)*(ry/25.4)/aa_y+(shunt adjust=image_adjust_extend 0.5 adjust=image_adjust_reduce -0.5 0) Int) 1)*aa_y
  p := image_prototype x0 y0 x0+size_x/(rx/25.4)*((x1-x0)/(abs x1-x0)) y0+size_y/(ry/25.4)*((y1-y0)/(abs y1-y0)) size_x size_y gamut

function image_prototype p options -> p2
  arg ImagePrototype p p2 ; arg Str options
  var Float margin := options option "margin" Float 0
  var Float x0 := options option "x0" Float p:x0-margin
  var Float y0 := options option "y0" Float p:y0-margin
  var Float x1 := options option "x1" Float p:x1+margin
  var Float y1 := options option "y1" Float p:y1+margin
  var Link:ColorGamut g :> p gamut
  if g:transparency>0 and (options option "drop_transparency")
    var Link:ColorGamut g2 :> color_gamut (replace g:name "+transparencies" "")
    var Link:ColorGamut g2 :> color_gamut (shunt g:name="rgba" "rgb" (replace g:name "+transparencies" ""))
    if g2=success
      g :> g2
  var Int size_x := options option "size_x" Int
  var Int size_y := options option "size_y" Int
  if size_x<>undefined and size_y<>undefined and not (options option "resolution")
    p2 := image_prototype x0 y0 x1 y1 size_x size_y g
  else
    if not ((options (options option_position "resolution" 0) options:len) parse word:"resolution" (var Float dpi_x) (var Float dpi_y) any)
      dpi_x := options option "resolution" Float undefined ; dpi_y := dpi_x
      if dpi_x=undefined and p:size_x<>undefined
        dpi_x := p:size_x/(abs p:x1-p:x0)*25.4
      if dpi_y=undefined and p:size_y<>undefined
        dpi_y := p:size_y/(abs p:y1-p:y0)*25.4
    if not ((options (options option_position "antialiasing" 0) options:len) parse word:"antialiasing" (var Int aa_x) (var Int aa_y) any)
      aa_x := options option "antialiasing" Int 1 ; aa_y := aa_x
    p2 := image_prototype x0 y0 x1 y1 dpi_x dpi_y aa_x aa_y image_adjust_extend g