/* */
/* Load up advanced REXX functions */
call RxFuncAdd 'SysLoadFuncs', 'RexxUtil', 'SysLoadFuncs'
call SysLoadFuncs

foo=rxfuncquery('rxgdloadfuncs')
if foo=1 then do
  Call RxFuncAdd 'RxgdLoadFuncs', 'RXGDUTIL', 'RxgdLoadFuncs'
  Call RxgdLoadFuncs
end

say " This utility is meant to be used in conjunction with the gif_text utility "
say
say " Given a grid of fonts in a .GIF file, and a .IND file containing some "
say " basic info, this utility will create an 'alphabyte' -- "
say "      it will extract seperate .GIF files for each  character referenced "
say "      in the .IND file.   "
say " (this can be useful for debugging the .IND file)"
say

call charout , " Enter ind file (that contains info on the Grid Of Fonts) ? "
pull anind

if pos('.',anind)=0 then anind=anind'.ind'
parse var anind anind0 '.' .

afile=anind
if afile=' ' then exit
ii=0
if stream(afile,'c','query exists')=' ' then do
 say " no such file: " afile
 exit
end
do until lines(afile)=0
  ii=ii+1
  tmp.ii=linein(afile)
end
tmp.0=ii
lines.0=ii
do iii=1 to lines.0
   lines.iii=tmp.iii
end /* do */
foo=stream(afile,'c','close')

textcolor='000000' ; backcolor='ffffff'
defgifs=' '; xoffset=0 ; yoffset=0 ; inrow=16 ; hchar=47  ; wchar=35 ;isbw=1
charset=' !"'||"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcdefghijklmnopqrstuvwxyz{|}~"

/* default names for odd characters */
namelist.0='!@#$%^&*()_+{}|:"<>?/.,;\][`~'||"'=-"
namelist.1='exclam'
namelist.2='amp'
namelist.3='hash'
namelist.4='dollar'
namelist.5='percent'
namelist.6='caret'
namelist.7='amp'
namelist.8='ast'
namelist.9='lparen'
namelist.10='rparen'
namelist.11 ='under'
namelist.12='plus'
namelist.13='lcurly'
namelist.14='rcurly'
namelist.15='vbar'
namelist.16='colon'
namelist.17='dquote'
namelist.18='lt'
namelist.19='gt'
namelist.20='quest'
namelist.21='fslash'
namelist.22='period'
namelist.23='comma'
namelist.24='semic'
namelist.25='bslash'
namelist.26='rsqparen'
namelist.27='lsqparen'
namelist.28='lquote'
namelist.29='squigle'
namelist.30='quote'
namelist.31='equal'
namelist.32='dash'


do mm=1 to lines.0
   foo=strip(lines.mm)
   if abbrev(foo,';')=1 | foo="" then iterate
   if pos('=',foo)=0 then iterate
   parse var foo athing '=' stuff ; athing=strip(translate(athing))
   select
      when athing='DEFAULTS' then  defgifs=strip(stuff)
      when athing='TEXT' then do
               stuff2=get_from_hex(stuff)
              if stuff2<>' ' then textcolor=strip(stuff)
      end
      when athing='BACK' then do
         stuff2=get_from_hex(stuff)
         if stuff2<>' ' then backcolor=strip(stuff)
      end
      when athing='DEF_OFFSET' then do
             stuff=translate(stuff,' ',',')
             parse var stuff a1 a2
             if datatype(a1)='NUM'  then xoffset=a1
             if datatype(a2)='NUM'  then yoffset=a2
      end  /* Do */
      when athing='DEF_CHARSIZE' then do
             stuff=translate(stuff,' ',',')
             parse var stuff a1 a2
             if datatype(a1)='NUM'  then wchar=a1
             if datatype(a2)='NUM'  then hchar=a2
      end  /* Do */
      when athing='DEF_CHARS' then charset=stuff
      when athing='DEF_BW' then isbw=pos(strip(translate(stuff)),'Y YES 1')
      when athing='DEF_INROW' then
              if datatype(strip(stuff))='NUM' then inrow=strip(stuff)
      otherwise nop
   end  /* select */
end /* do */
say "DefChars: " charset
say "GIF file: "defgifs
im = RxgdImageCreateFromGIF(defgifs)
if im=1 | im=0 then  do
 say "Error, could not process " defgifs 
 say " Are you running EXT_GIFS from the font's own directory?"
  exit
end

say " Reading from fonts displayed in: " defgifs 
say " The following characters will be produced: " charset

hlist.0=0
backcolor=get_from_hex(backcolor)
   parse var backcolor bdefr bdefg bdefb
textcolor=get_from_hex(textcolor)
   parse var textcolor tdefr tdefg tdefb
ido=0
/* for each character in the charset ... */
/*do ic=1 to length(charset)*/
do ic=1 to length(charset)
     achar=substr(charset,ic,1)
     if achar=' ' then iterate

/* determine x offset: */
   irow=1+((ic-0.1)%inrow)
   icol=ic-((irow-1)*inrow)

/* upper left is 0,0 */
   xat=xoffset + ((icol-1)*wchar)
   yat=yoffset+ ((irow-1)*hchar)

   cim=rxgdimagecreate(wchar,hchar)

   foo=rxgdimagecopy(cim,im,0,0,xat,yat,wchar,hchar)


   foo=rxgdimagecolordeallocate(cim,0)
   oy1=rxgdimagecolorallocate(cim,bdefr,bdefg,bdefb)
   foo=rxgdimagecolordeallocate(cim,1)
   oy2=rxgdimagecolorallocate(cim,tdefr,tdefg,tdefb)

   acharg=achar
   if translate(achar)<>achar then acharg=achar'lc'

   if pos(translate(achar),'1234567890ABCDEFGHIJKLMNOPQRSTUVXWYZ#-_%$')=0 then DO
        ACHARg=a_defname(achar)
        call charout," For: "achar ": enter name (ENTER="ACHARG"):"
        pull acharg0
        if acharg0<>'' then do 
            acharg=acharg0
        end /* do */
        iih=hlist.0+1
        hlist.iih=achar ; hlist.iih.!ascii=c2d(achar)
        parse var acharg acharg '.' .
        hlist.iih.!file=acharg'.GIF'
        hlist.0=iih
   end  /* Do */
   acharg=acharg'.GIF'
  foo=rxgdimagegif(cim,acharG)
   say  " Writing character " achar "(@ offset "  xat yat ") to : " acharg
   ido=ido+1
  foo= RxgdImageDestroy(cim)


end /* do */
say " Total files written= " ido '(' hlist.0 ' with non-standard names)'

if hlist.0>0 then do
  anind1=systempfilename(anind0'.???')
  say "Note: you should add the contents of "anind1 " to "anind
  foo=stream(anind1,'c','open write')
  do ii=1 to hlist.0
    call lineout anind1,'##'||hlist.ii.!ascii' 'hlist.ii.!file'   'hlist.ii
  end /* do */
  call lineout anind1
  foo=stream(anind1,'c','close')
end

foo= RxgdImageDestroy(im)

exit




/**************************/
/* convert ff21b3 "hex" color code to decimal r g b values
  If bad value, return ' /' */
get_from_hex:procedure
parse arg hval

hval=strip(strip(hval),,'"')
hval=strip(hval,,'#')
select 
  when length(hval)<>6 then return ' '
  when verify(translate(hval),'0123456789ABCDEF')>0 then return ' '
  otherwise do
    a1=left(hval,2)
    a2=substr(hval,3,2)
    a3=substr(hval,5,2)
    r=x2d(a1)
    g=x2d(a2)
    b=x2d(a3)
  end
end /* do */
return r ' ' g ' ' b

/***********************/
/* some default names */
a_defname:procedure expose  namelist.
parse arg achar
ii=pos(achar,namelist.0)
if ii>0 then do
   return translate(namelist.ii)||'.GIF'
end
return 'ASC_'||c2d(achar)||'.GIF'