! Copyright (C) 2001 Ray Ontko & Co.
! http://www.ontko.com
!
! This program is free software; you can redistribute it and/or modify
! it under the terms of the GNU General Public License as published by
! the Free Software Foundation; either version 2 of the License, or
! (at your option) any later version.
!
! 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.
!
! A copy of the GPL is available at the GNU web site:
!   http://www.gnu.org/
!   http://www.gnu.org/copyleft/gpl.html
!
!++
!
! Name
!
!   bmp_to_hpg.sqr
!
! Description
!
!   Converts a .bmp (BitMaP) file into an .hpg (HP/GL) file suitable
!   for use with SQR.
!
! Command Line
!
!   sqr bmp_to_hpg / -xl -xb <input-file> <output-file> <bgcolor>
!
! Known Bugs and Limitations
!
!   Does not allow user to adjust number of pixels per inch.  If added,
!   this could be different in each dimension.  We have assumed 72
!   pixels per inch.  Another reasonable choice might have been 96.
!   300 would also be a convenient choice for users.
!
!   Does not support compressed images.  The logic for this is
!   fairly complicated, but doable.  A work-around is to load
!   the image into Paint and save it as a Monochrome Bitmap 
!   or as a 24-bit Bitmap and then use this new file as input to
!   this program.  If you use the Monochrome Bitmap file type, all
!   light colored bits will map to white, and all dark colored bits
!   will map to black.  If you use the 24-bit Bitmap file type, all
!   color information will be preserved in the saved file.  However,
!   this program will only allow one color to be used as the background
!   color; all other colors are mapped as foreground colors.
!
!--
!
! Author
!
!   Ray Ontko
!   Ray Ontko & Co
!   rayo@ontko.com
!
! Modification History
!
! Name             Date       Comment
! ---------------- ---------- ----------------------------------------
! Ray Ontko        1999/12/29 Created
! Ray Ontko        2001/11/07 Updated documentation
!

! maximum number of entries in the colormap
#define COLORMAP_SIZE 256

! maximum number of lines in the bitmap
#define BITMAP_SIZE 1000

#define I_FILE 1
#define O_FILE 2
#define O_MAX 100

#define BMP_PPI 72
#define HP_SCALE 1016/{BMP_PPI}
#define HP_PEN_WIDTH 25.4/{BMP_PPI}

!------------------------------------------------------------ begin-setup
begin-setup
create-array
   name=colormap
   size={COLORMAP_SIZE}
   field=color:number
create-array
   name=bitmap
   size={BITMAP_SIZE}
   field=line:char
end-setup

!---------------------------------------------------------- begin-program
begin-program
do main
end-program

!------------------------------------------------------------------- main
begin-procedure main
input $iname 'Input file'
input $oname 'Output file'
input $bgcolor 'Background color (RGB) [FFFFFF]'

if isblank( $bgcolor )
   move 'FFFFFF' to $bgcolor
end-if
if translate( $bgcolor, '0123456789ABCDEFabcdef' ,
                        '0000000000000000000000' ) != '000000'
   string '"' $bgcolor '" is not a hexidecimal RGB color value' by '' into $msg
   do fatal_error( $msg )
end-if
do hex_number( $bgcolor , #bgcolor )

open $iname as {I_FILE} for-reading record=1:fixed_nolf status=#status
if #status
   string 'unable to open "' $iname '" for input' by '' into $msg
   do fatal_error( $msg )
end-if

do read_word_unsigned( {I_FILE} , #bfType )
do read_long_unsigned( {I_FILE} , #bfSize )
do read_word_unsigned( {I_FILE} , #bfReserved1 )
do read_word_unsigned( {I_FILE} , #bfReserved2 )
do read_long_unsigned( {I_FILE} , #bfOffBits )
#debug show '#bfType      = ' #bfType
#debug show '#bfSize      = ' #bfSize
#debug show '#bfReserved1 = ' #bfReserved1
#debug show '#bfReserved2 = ' #bfReserved2
#debug show '#bfOffBits   = ' #bfOffBits

do read_long_unsigned( {I_FILE} , #biSize )
do read_long_unsigned( {I_FILE} , #biWidth )
do read_long_unsigned( {I_FILE} , #biHeight )
do read_word_unsigned( {I_FILE} , #biPlanes )
do read_word_unsigned( {I_FILE} , #biBitCount )
do read_long_unsigned( {I_FILE} , #biCompression )
do read_long_unsigned( {I_FILE} , #biSizeImage )
do read_long_unsigned( {I_FILE} , #biXPelsPerMeter )
do read_long_unsigned( {I_FILE} , #biYPelsPerMeter )
do read_long_unsigned( {I_FILE} , #biClrUsed )
do read_long_unsigned( {I_FILE} , #biClrImportant )
#debug show '#biSize          = ' #biSize
#debug show '#biWidth         = ' #biWidth
#debug show '#biHeight        = ' #biHeight
#debug show '#biPlanes        = ' #biPlanes
#debug show '#biBitCount      = ' #biBitCount
#debug show '#biCompression   = ' #biCompression
#debug show '#biSizeImage     = ' #biSizeImage
#debug show '#biXPelsPerMeter = ' #biXPelsPerMeter
#debug show '#biYPelsPerMeter = ' #biYPelsPerMeter
#debug show '#biClrUsed       = ' #biClrUsed
#debug show '#biClrImportant  = ' #biClrImportant

if #biCompression > 0
   move #biCompression to $biCompression '88888'
   string 'compressed image format "' $biCompression '" not yet supported'
      by '' into $msg
   do fatal_error( $msg )
end-if

! read the color map
move 0 to #color_count
if #biBitCount <= 8
   let #color_count = power( 2 , #biBitCount )
   move 0 to #i
   while #i < #color_count
      do read_long_unsigned( {I_FILE} , #color )
      ! strip off the high-order reserved byte from the color value
      let #color = mod(#color,16777216)
      put #color into colormap(#i) color
      #debug do hex_string( #color , 6 , $s )
      #debug if #biClrUsed > 0 and #i < #biClrUsed or #biClrUsed = 0
         #debug show #i edit 999 ' ' $s
      #debug end-if
      add 1 to #i
   end-while
   if #biClrUsed > 0
      move #biClrUsed to #color_count
   end-if
end-if

! scan the color map for the bgcolor
move -1 to #bgmapcolor
move 0 to #i
while #i < #color_count
   get #color from colormap(#i) color
   if #bgcolor = #color
      move #i to #bgmapcolor
      break
   end-if
   add 1 to #i
end-while
if #color_count > 0 and #bgmapcolor = -1
   #debug show 'Color Map'
   move 0 to #i
   while #i < #color_count
      get #color from colormap(#i) color
      do hex_string( #color , 8 , $color )
      #debug show #i edit 999 ' ' $color
      add 1 to #i
   end-while
   string 'unable to find background color "' $bgcolor '" in color map'
      by '' into $msg
   do fatal_error( $msg )
end-if
#debug show '#bgmapcolor = ' #bgmapcolor

! read the bit map
let #bytes_per_line = trunc( ( #biWidth * #biBitCount + 31 ) / 32 , 0 ) * 4
move '' to $line
move 0 to #bitmap_count
move 0 to #i
while 1
   do read_byte_unsigned( {I_FILE} , #x )
   if #end-file
      break
   end-if
   evaluate #biBitCount
   when = 1
      do bin_string( #x , 8 , $s )
      #debug show #i edit 99999 ' ' $s
      move 0 to #k
      while #k < 8
         extract $c from $s #k 1
         do bin_number( $c , #c )
         if #c = #bgmapcolor
            concat ' ' with $line
         else
            concat 'X' with $line
         end-if
         add 1 to #k
      end-while
      break
   when = 4
      let #hi = trunc( #x / 16 , 0 )
      let #lo = mod( #x , 16 )
      #debug show #i edit 99999 ' ' #hi edit 99 ' ' #lo edit 99
      if #hi = #bgmapcolor
         concat ' ' with $line
      else
         concat 'X' with $line
      end-if
      if #lo = #bgmapcolor
         concat ' ' with $line
      else
         concat 'X' with $line
      end-if
      break
   when = 8
      #debug show #i edit 99999 ' ' #x edit 999
      if #x = #bgmapcolor
         concat ' ' with $line
      else
         concat 'X' with $line
      end-if
      break
   when = 24
      do read_byte_unsigned( {I_FILE} , #g )
      do read_byte_unsigned( {I_FILE} , #b )
      add 2 to #i
      multiply 256 times #x
      add #g to #x
      multiply 256 times #x
      add #b to #x
      #debug do hex_string( #x , 6 , $x ) 
      #debug show #i edit 99999 ' ' $x
      if #x = #bgcolor
         concat ' ' with $line
      else
         concat 'X' with $line
      end-if
   end-evaluate
   add 1 to #i
   if mod(#i,#bytes_per_line) = 0
      let $line = substr($line,1,#biWidth)
      put $line into bitmap(#bitmap_count) line
      add 1 to #bitmap_count
      #debug let $line = substr($line,1,80)
      #debug show $line
      move '' to $line
   end-if
end-while
close {I_FILE}

! scan our bitmap lines and produce the hpgl file

open $oname as {O_FILE} for-writing record={O_MAX}:vary status=#status
if #status
   string 'unable to open "' $oname '" for output' by '' into $msg
   do fatal_error( $msg )
end-if

let $x = edit( round( #biWidth * {HP_SCALE} , 0 ) , '88888' )
let $y = edit( round( #biHeight * {HP_SCALE} , 0 ) , '88888' )
let $pw = edit( {HP_PEN_WIDTH} , '8.888888' )
write {O_FILE} from 'IN;PU0,0;PU' $x ',' $y ';SP1;PW' $pw

move 0 to #i
while #i < #bitmap_count
   get $line from bitmap(#i) line
   move 0 to #pen
   move 0 to #j
   while #j < #biWidth
      extract $c from $line #j 1
      if $c = 'X' and #pen = 0
         ! put pen down
         move 1 to #pen
         ! pen up and move to this location
         let $x = edit( round( #j * {HP_SCALE} , 0 ) , '888888' )
         let $y = edit( round( #i * {HP_SCALE} + {HP_SCALE} / 2 , 0 ) , '888888' )
         write {O_FILE} from 'PU' $x ',' $y ';'
      else
         if $c = ' ' and #pen = 1
            move 0 to #pen
            ! emit pen up code for previous location
            let $x = edit( round( #j * {HP_SCALE} , 0 ) , '888888' )
            let $y = edit( round( #i * {HP_SCALE} + {HP_SCALE} / 2 , 0 ) , '888888' )
            write {O_FILE} from 'PD' $x ',' $y ';'
         end-if
      end-if
      add 1 to #j
   end-while
   if #pen = 1
      let $x = edit( round( #j * {HP_SCALE} , 0 ) , '888888' )
      let $y = edit( round( #i * {HP_SCALE} + {HP_SCALE} / 2 , 0 ) , '888888' )
      write {O_FILE} from 'PD' $x ',' $y ';'
   end-if
   add 1 to #i
end-while
close {O_FILE}

end-procedure ! main

!----------------------------------------------------- read_byte_unsigned
begin-procedure read_byte_unsigned( #file , :#u )
read #file into #u:1
if not #_end-file
   if #u < 0
      add 256 to #u
   end-if
end-if
end-procedure ! read_byte_unsigned

!----------------------------------------------------- read_word_unsigned
begin-procedure read_word_unsigned( #file , :#u )
read #file into #t:1
if not #_end-file
   read #file into #u:1
   if not #_end-file
      if #t < 0
         add 256 to #t
      end-if
      if #u < 0
         add 256 to #u
      end-if
      multiply 256 times #u
      add #t to #u
   end-if
end-if
end-procedure ! read_word_unsigned

!----------------------------------------------------- read_long_unsigned
begin-procedure read_long_unsigned( #file , :#u )
read #file into #r:1
if not #_end-file
   read #file into #s:1
   if not #_end-file
      read #file into #t:1
      if not #_end-file
         read #file into #u:1
         if not #_end-file
            if #r < 0
               add 256 to #r
            end-if
            if #s < 0
               add 256 to #s
            end-if
            if #t < 0
               add 256 to #t
            end-if
            if #u < 0
               add 256 to #u
            end-if
            multiply 256 times #u
            add #t to #u
            multiply 256 times #u
            add #s to #u
            multiply 256 times #u
            add #r to #u
         end-if
      end-if
   end-if
end-if
end-procedure ! read_long_unsigned

!------------------------------------------------------------- bin_string
begin-procedure bin_string( #u , #n , :$s )
! high order bits are on the left
move 0 to #i
move '' to $s
while #i < #n
   let $s = substr('01',1+mod(#u,2),1) || $s
   let #u = trunc( #u / 2 , 0 )
   add 1 to #i
end-while
end-procedure ! bin_string

!------------------------------------------------------------- oct_string
begin-procedure oct_string( #u , #n , :$s )
move 0 to #i
move '' to $s
while #i < #n
   let $s = substr('01234567',1+mod(#u,8),1) || $s
   let #u = trunc( #u / 8 , 0 )
   add 1 to #i
end-while
end-procedure ! oct_string

!------------------------------------------------------------- hex_string
begin-procedure hex_string( #u , #n , :$s )
move 0 to #i
move '' to $s
while #i < #n
   let $s = substr('0123456789ABCDEF',1+mod(#u,16),1) || $s
   let #u = trunc( #u / 16 , 0 )
   add 1 to #i
end-while
end-procedure ! hex_string

!------------------------------------------------------------- bin_number
begin-procedure bin_number( $s , :#u )
let $s = ltrim(rtrim($s,' '),' ')
let #l = length($s)
move 0 to #u
move 0 to #i
while #i < #l
   extract $c from $s #i 1
   find $c in '01' 0 #c
   if #c < 0
      break
   end-if
   multiply 2 times #u
   add #c to #u
   add 1 to #i
end-while
end-procedure ! bin_number

!------------------------------------------------------------- oct_number
begin-procedure oct_number( $s , :#u )
let $s = ltrim(rtrim($s,' '),' ')
let #l = length($s)
move 0 to #u
move 0 to #i
while #i < #l
   extract $c from $s #i 1
   find $c in '01234567' 0 #c
   if #c < 0
      break
   end-if
   multiply 8 times #u
   add #c to #u
   add 1 to #i
end-while
end-procedure ! oct_number

!------------------------------------------------------------- hex_number
begin-procedure hex_number( $s , :#u )
let $s = upper(ltrim(rtrim($s,' '),' '))
let #l = length($s)
move 0 to #u
move 0 to #i
while #i < #l
   extract $c from $s #i 1
   find $c in '0123456789ABCDEF' 0 #c
   if #c < 0
      break
   end-if
   multiply 16 times #u
   add #c to #u
   add 1 to #i
end-while
end-procedure ! hex_number

!------------------------------------------------------------ fatal_error
begin-procedure fatal_error( $msg )
show 'error: ' $msg
move 1 to #_return-status
stop quiet
end-procedure ! fatal_error