/* 23 June 1999.   SRE-http utility and generic CGI-BIN script:
GIF_TEXT 1.3b: create a gif file containing a message, using an
          "alphabyte" collection of character files, a "complete"
          font in single image file, or a ttf font.

This program will work as a:
 1)"native" SRE-http add-on,
 2) as a generic CGI-BIN script
 3) a stand/alone program
...it will automatically detect how it's being called.

NOTE: You MUST set the GIF_DIR_ROOT parameter below (other parameters are
      optional).

************************************************************************/

signal on error name wow1 ; signal on syntax name wow1 ;


/******************************************************
  ***********BEGIN USER CHANGABLE PARAMETERS ******************************
  ***********BEGIN USER CHANGABLE PARAMETERS ******************************
  ***********BEGIN USER CHANGABLE PARAMETERS ******************************/
 
/*-                   --------------------
                    User changeable parameters

The user changeable parameters are:

GIF_DIR_ROOT : The "root" directory of the "alphabytes".

         !!!!  YOU MUST SET GIF_DIR_ROOT WHEN YOU INSTALL GIF_TEXT  !!!!!
                All the other parameters can be left unchanged with
                minimal deteriment, but GIF_TEXT will not work
                if GIF_DIR_ROOT is not properly set.

SEND_PIECES: Try to send early versions of the image, as they become available
DEFAULT_FONT : The default "alphabyte font" (actually, it's directory)
FIGDIST_TYPE : Method for computing "distances"
FONT_NAME : Name (prefix) used to match characters to .GIF files
FONT_INDEX : Index file with "alphabyte specific" configuration information
CACHE_SIZE : The maximum number of images to "cache"
CACHE_DURATION : Maximum duration of cached images
HEIGHT : Default height of the created image
WIDTH : Default width of the created image
LINE_SEP: Seperation between lines of multi-line message (in pixels)
X_FRAME: Width of frame, in pixels (left and right)
X_OFFSET : "shadow" offset in x direction 
Y_FRAME: Height of frame, in pixels (top and bottom)
y_offset : "shadow" offset in y direction
TIME_FMT : Default format to use when display current time
DATE_FMT : Default format to use when displaying current date
DEF_BACKCOLOR= Default backcolor
DEF_TEXTCOLOR= Default textcolor (used when no character .GIF file is available)
DEF_TRANSPARENT = Default transparent color index
DEF_TEXTSIZE = Default size of default text characters

*  You MUST set the GIF_DIR_ROOT parameter
*  The SEND_PIECES parameter is useful if you are using SRE-http, and 
    large/complicated images are likely
    to be created (which may require the client to wait a minute or more). 
*  You should, but do not need to, set the TIME_FMT, DATE_FMT, and FONT_DIR
   parameters.
*  You should probably set HEIGHT=0 and WIDTH=0.
*  You should probably set FONT_NAME=' ' and FONT_INDEX=' '
*  The DEF_BACKCOLOR, and DEF_TEXTCOLOR are usually
   overridden by "alphabyte" specific values,so you probably
   don't need to worry about them.
*  The DEF_TEXTSIZE is  rarely used (only if there are NO matching characters)!
*  The DEF_TRANSPARENT should almost always equal 0

*  CACHE_SIZE=100 and CACHE_DURATION=1 are reasonable values; but if you
   want to avoid clutter, set CACHE_SIZE=0 (in which case, the 
   CACHE option is ignored)
                               -----------------
*/

/*  !!!! You MUST set the GIF_DIR_ROOT parameter !!!! */
/* The "base directory" of the alphabytes (the collection of character gifs) */
/* if no drive is specified, the default drive (i.e.; the goserve working
directory) will be used */

GIF_DIR_ROOT='\goserve\alphabyt'

/* The root directory for TTF fonts */

TTF_DIR_ROOT='\ttf'


/* Attempt to send "pieces" (actually, less detailed versions) of the image as it becomes
   available (only works with browsers that recognize connection:keep-alive). 
   1=yes, 0=no
   Send_pieces will ONLY work if GIF_TEXT is called as an SRE-http addon*/
send_pieces=0


/* Default font directory (relative to gif_dir_root) */
DEFAULT_FONT='enviro'

/* default font name.If ' ', use "font_dir own name". This should NOT
   include directory information */
font_name=' '

/* default "index file" (in font_dir) -- contains alphabyte specific
   configuration information. If ' ', usein font_name.ind.
   This should NOT contain subdirectory information. */
font_index=' '

img_prog='NETSCAPE -l en '  /* program string for displaying images */


/* the maximum number of images to cache. 0 means "disable caching of images"*/
cache_size=100

/* the maximum lifespan of an image cache file. 0 means "disable caching".
   (measured in days, no fractions allowed). */
cache_duration=1

/* default height in pixels (0= as big as needed) */
height=0
/* default width in pixels (0=as big as needed) */
width=0

/* default line seperation, in pixels (for multi line messages */
line_sep=2 

/* default size of frame, left and right */
x_frame=0 ; X_OFFSET=0

/* default size of frame, top and bottom */
y_frame=0 ; y_offset=0

/* time format (using REXX TIME('x') syntax); eg; N= 15:32:01*/
time_fmt='N'
/*date format (using REXX DATE('x') syntax ); eg; N=16 Jun 1997 */
date_fmt='N'

/* Set the default RGB intensities for the background (color table #0)
   Use a 6-hex-character (00 to ff); with 000000=black and ffffff=white.
   This may be overridden by the font-index file, or by an option  */
def_backcolor=b0b0b0


/* set values to use for characters when a .gif file can not be found 
   This may be overridden by the font-index file, or by an option */
def_textcolor=333333

/* size of text, in pixel, if NO gifs found */
def_text_size =15

/* set the "transparent color index" -- use a value between 0 and 255.
  If you do NOT want a transparent color index, use -1. */
def_transparent=0

/* verbose level (only used if called as cgi-bin script:
  0=none, 1=minimal, 2=more
 If called as SRE-http addon, then SRE-http's VERBOSE variable is used */
def_verbose=2


/* method for computing "distances"
   1=euclidean, 2=grid steps, 3=modified grid steps, 4=longest axis */
figdist_type=3

/* background scaling: 1 for yes, 0 for use tiles */
back_scale=0

/* mask file scaling : 1 for yes, 0 for use tiles */
mask_scale=0 


/* reverse mask: 0=no (0 pixel are invisible), 1=yes (>0 pixels are invisible) */
mask_reverse=0

/* maximum size of "URLS" to get as backgrounds (in bytes) */
max_urlsize=100000

/********** END of USER CHANGABLE PARAMETERS *********/
/********** END of USER CHANGABLE PARAMETERS *********/
/********** END of USER CHANGABLE PARAMETERS *********/


foo=rxfuncquery('rxgdloadfuncs')
if foo=1 then do
  Call RxFuncAdd 'RxgdLoadFuncs', 'RXGDUTIL', 'RxgdLoadFuncs'
  Call RxgdLoadFuncs
end
foo=rxfuncquery('rxgdloadfuncs')
if foo=1 then do
   if verb="" then do
        STRING "Sorry: RXGDUTIL.DLL is not available! Did you copy it to your LIBPATH? "
        return ' '
   end /* do */
   say 'Sorry: RXGDUTIL.DLL is not available! Did you copy it to your LIBPATH? '
   exit
end /* do */

/* Load up advanced REXX functions */
foo=rxfuncquery('sysloadfuncs')
if foo=1 then do
  call RxFuncAdd 'SysLoadFuncs', 'RexxUtil', 'SysLoadFuncs'
  call SysLoadFuncs
end

/* load rexx_ttf */
foo=rxfuncquery('rxttf_image')
if foo=1 then 
  call RxFuncAdd 'rxttf_image', 'RXTTF', 'rxttf_image'
foo=rxfuncquery('rxttf_image')
if foo=1 then say "Warning: RXTTF_IMAGE not available "

if datatype(CACHE_SIZE)<>'NUM'  then cache_size=0
if datatype(CACHE_DURATION)<>'NUM'  then cache_size=0
if datatype(DEF_VERBOSE)<>'NUM'  then def_verbose=1
if datatype(back_scale)<>'NUM'  then back_scale=0

if cache_size<1  then cache_size=0
if cache_duration<1 then cache_size=0

sqs.!got=rxfuncquery('SQRT')  /* is there a sqrt function available */

send_delay=12           /* time to wait before SENDing a piece */

if filespec('D',gif_dir_root)=' ' then do
     oof=directory()
     arf=filespec('d',oof)
     gif_dir_root=arf||gif_dir_root
end  /* Do */
if gif_dir_root=' ' then
    gif_dir_root=strip(basedir,'t','\')||'\alphabyt'

gif_dir_root=strip(gif_dir_root,'t','\')||'\'


ttf_dir_root=strip(ttf_dir_root,'t','\')||'\'

parse arg  ddir, tempfile, reqstrg,list,verb ,uri,user, ,
          basedir ,workdir,privset,enmadd,transaction,verbose, ,
         servername,host_nickname,homedir


a_box=d2c(3)
cprotocol='1.0'
if verbose="" then verbose=def_verbose

nttfs=0

/* check for CGI-BIN call */
is_cgi=0
fake_cgi=0
outputfile=""
if verb="" then do    /* is it cgi-bin? */
   method = value("REQUEST_METHOD",,'os2environment')  
   if method="" then do
       parse arg list
       if list="" then do
          list=ask_values()
          is_cgi=2         /* signals "stand alone */
          verbose=2
       end
       else do
          list=translate(list,"&"," ")
          is_cgi=1 ; fake_cgi=1
          parse value list with "&as="outputfile 
          parse var outputfile outputfile '&' .
          foo=stream(outputfile,'c','query exists')
          if foo<>'' then do
              say "ERROR: "foo "exists (overwrite not permitted)."
              exit
          end /* do */
       end;
       if list="" then exit
   end /* do */
   else do
      is_cgi=1
      if method='GET' then do
          list=value("QUERY_STRING",,'os2environment')
      end
      else do
         tlen = value("CONTENT_LENGTH",,'os2environment')
         list=charin(,,tlen)
      end /* do */
      verbose=def_verbose
   end
end

if is_cgi=0 then do             /* called as sre addon */
  if  verb="GET" then do
      parse var uri . '?' list   /* if srefilter addon, get purer version of request string */
  end    
  cp=extract('clientprotocol')
  parse var cp . '/' cprotocol
end

aa=sysfiletree(gif_dir_root||'*.*','arf','b')
if arf.0=0 then do
   call gpmprintf(" GIF_TEXT: GIF_DIR_ROOT is empty or missing: "gif_dir_root)
   if is_cgi=1 then
        return
   return 0
end /* do */


/*  request options understood:
   FONT_DIR, SEND, FONT_NAME, FONT_INDEX, TIME_FMT, DATE_FMT, BACKCOLOR,
   TEXTCOLOR, TRANSPARENT, WIDTH, HEIGHT, LITERAL,X_FRAME,y_FRAME 
   X_OFFSET, y_offset, X_SCALES Y_SCALES V_ALIGN LINE_JA
    SLIDE2 SLIDE SLIDE_VERT SLIDE_HORIZ SLIDE_THRESH SLIDE_PROB
    SLIDE_COORD SLIDE_SIZE SLIDE_RED SLIDE_GREEN SLIDE_BLUE SPECIAL
    FIGDIST_TYPE  TTF_FONT TTF_FONT_SIZE LINE_SEP
 */

/* set to blank means "use font_index value if none specified in request */
send_bim=0
back_file=' ' ; text=' ' ; back2_file=''; mask_file=''
amessage=' ' ; cache_file=' ';  do_cache=0
backcolor=' ' ; textcolor=' ' ; transparent=""
fontdir=default_font; fontname=font_name ; fontindex=font_index ;fontdir2=''
many_type=0 ; many_type_max=0
ttf_font='' ;ttf_font_size=0 ;ttffile=''
x_scales="" ;y_scales="" ; y_valign="" ; slide2=' ';slide="" ;  slide_vert="" ; 
slide_thresh='P1' ; slide_horiz=''
slide_red="" ; slide_green="" ;slide_blue=""
slide_size=""
slide_coord=""
slide_xcoord="" ; slide_ycoord="" ; slide_prob=''
special=''
maskfile='' ; mask_threshold=0
linealign='L'

/* pull options from request */
literal=0 ;
 do until list=""                /* get user input */
   parse var list a1 '&' list
   parse var a1 a1a '=' a1b0
   a1a=translate(strip(a1a))
   a1b1=packur2(a1b0)
   a1b=strip(translate(a1b1))
   select
      when a1a="FONT_DIR" | a1a="FONT" then do
          if a1b<>' ' then fontdir=a1b
      end  /* Do */
      when a1a="FONT_DIR2" | a1a="FONT2" then do
          if a1b<>' ' then fontdir2=a1b
      end  /* Do */

      when a1a="FONT_NAME" | a1a="NAME" then do
           if a1b<>' ' then fontname=a1b
      end


      when a1a="TTF_FONT" then do
           if a1b<>' ' then ttf_font=strip(a1b1)
      end /* do */
      when a1a="TTF_FONT_SIZE" then do
           if datatype(a1b)='NUM' then ttf_font_size=a1b
      end /* do */

      when a1a="FONT_INDEX" | a1a="INDEX" then do
            if a1b<>' ' then fontindex=a1b
      end  /* Do */
      when abbrev(a1a,'TIME')=1 then time_fmt=a1b
      when abbrev(a1a,'CACHE')=1 then do
                cache_file=strip(a1b)
                do_cache=1
                if a1a='CACHE2' then do_cache=2
      end  /* Do */
      when abbrev(a1a,'DATE')=1 then date_fmt=a1b
      when abbrev(a1a,"TEXTC")=1 then textcolor=a1b
      when abbrev(a1a,"BACKG")+abbrev(a1a,"BACKC")>0 then backcolor=a1b
      when abbrev(a1a,"TRANS")=1 then do
         if datatype(a1b)='NUM' then transparent=a1b
      end
      when a1a="WIDTH" | a1a="W" then width=a1b
      when abbrev(a1a,'SPECIAL')=1 then special=special' 'a1b
      when a1a="SEND" then send_pieces=a1b
      when abbrev(a1a,'FIGDIST')=1 then do
          if wordpos(a1b,'1 2 3')>0 then  figdist_type=a1b
      end /* do */
      when abbrev(a1a,'MANY_')=1 then do
          if datatype(a1b)='NUM' then
               many_type_max=a1b
          else
               many_type=wordpos(translate(a1b),'CYCLE FIT END RANDOM')
      end /* do */
      when abbrev(a1a,"X_F")=1 then do
           if datatype(a1b)='NUM' then x_frame=a1b
      end
      when abbrev(a1a,"Y_F")=1 then do
          if datatype(a1b)='NUM' then y_Frame=a1b
      end
      when abbrev(a1a,"X_OF")=1 then do
           if datatype(a1b)='NUM' then X_OFFSET=a1b
      end
      when abbrev(a1a,"Y_OF")=1 then do
          if datatype(a1b)='NUM' then y_offset=a1b
      end


      when a1a="HEIGHT" | a1a="H" then height=a1b
      when a1a='LINE_SEP' then line_sep=a1b
      when abbrev(a1a,"LIT")=1 then literal=a1b
      when a1a="BACK" | a1a="BACK_FILE" then back_file=a1b
      when a1a="BACK2" | a1a="BACK2_FILE" then back2_file=a1b
      when a1a="BACK_SCALE" | a1a="BKSC" then back_scale=wordpos(translate(a1b),'Y YES 1')
      when a1a="MASK" | a1a="MASK_FILE" then mask_file=a1b
      when a1a="MASK_SCALE" | a1a="MASKSC" then mask_scale=wordpos(translate(a1b),'Y YES 1')
      when a1a='MASK_REVERSE' | a1a='MASK_R' then mask_reverse=wordpos(translate(a1b),'Y YES 1')
      when a1a="MASK_THRESHOLD" | a1a="MASK_T" then  mask_threshold=strip(a1b)
      when abbrev(a1a,'X_SC')+abbrev(a1a,'XSCA')>0 then x_scales=a1b
      when abbrev(a1a,'Y_SC')+abbrev(a1a,'YSCA')>0 then y_scales=a1b
      when abbrev(a1a,'VALI')+abbrev(a1a,'V_ALI') + abbrev(a1a,'Y_VAL')+ abbrev(a1a,'YVAL')>0 then y_valign=a1b
      when abbrev(a1a,'SLIDE_H')=1  then slide_horiz=a1b
      when abbrev(a1a,'SLIDE_T')=1  then slide_thresh=a1b
      when abbrev(a1a,'SLIDE_V')=1  then slide_vert=a1b
      when abbrev(a1a,'SLIDE_F')=1 | a1a='SLIDE'  then  do
          ee=translate(a1b,'\','/')
          ee=strip(a1b,'l','\')
          slide=gif_dir_root||ee
      end
      when abbrev(a1a,'SLIDE2_F')=1 | a1a='SLIDE2'  then  do
          slide2=a1b
      end
      when abbrev(a1a,'SLIDE_S')=1  then do
          if datatype(a1b)='NUM'  then slide_size=a1b
      end  /* Do */
      when abbrev(a1a,'SLIDE_C')=1  then slide_coord=a1b
      when abbrev(a1a,'JUST')=1 | abbrev(a1a,'LINE_J')=1 then line_just=translate(left(a1b,1))
      when abbrev(a1a,'SLIDE_R')=1  then slide_red=a1b
      when abbrev(a1a,'SLIDE_G')=1  then slide_green=a1b
      when abbrev(a1a,'SLIDE_B')=1  then slide_blue=a1b
      when abbrev(a1a,'SLIDE_P')=1  then slide_prob=a1b

      when a1a="MESSAGE" | a1a="TEXT" then do
         a1b0=strip(a1b0,,'"')
         amessage=packur2(a1b0)
      end
      otherwise nop
   end  /* select */
end /* do */
if amessage="" then amessage=' '

if verbose>1 then call gpmprintf(' GIF_TEXT font= ' fontdir ', message: 'amessage)

/* if send_pieces, then see if the browser supports multi part documents (connection:keep-alive) */
if is_cgi=0 & wordPos(translate(send_pieces),'Y YES 1')>0 then do
    a=translate(strip(reqfield('Connection')))
    a2=translate(strip(reqfield('PROXY-Connection')))
    if a<>'KEEP-ALIVE' & a<>'MAINTAIN' , 
       & a2<>'KEEP-ALIVE' & a2<>'MAINTAIN' & cprotocol<'1.1' then do
         send_pieces=0            /* browser does NOT support connection:keep-alive */
    end                
    else do
        send_pieces=1   /*  it does */
    end /* do */
end
else  do
   send_pieces=0      /* send_Pieces ONLY works as SRE-http addon */
end  /* Do */

call fix_defaults               /* set some default parameters */

if result=2 then signal shipit

call fix_options                /* using font_index and request stuff, set options */
call fix_message                /* fix up message (special code replacmenet */
call check_ndims

ttf_font0=ttf_font
ttf_font_size0=ttf_font_size
ttffile0=ttffile
was_ttffile=0

/* DONE WITH INITIALIZATIONS  ----------------------- */

/* for each charater in message, get it's gif file (if avaiable), it's
   size, and it's scale factors */
len0 = Length(amessage)          /* amessage is message, after $t, etc modifications */
xmess=0; ymess=0 ; cfound=0
ysize_tot=0 ; xsize_tot=0
l=0; l0=0; newls=''
do until l0 >=len0
   l0=l0+1

   achar = substr(amessage,l0,1)
   ichar=c2d(achar)
   if ichar=10 then do          /* newline */
       newls=newls' 'l   /* record position, and drop character */
       iterate
   end /* do */

   if ichar=6 then do           /* font switch -- use carefully */
       parse var user_fonts fontname user_fonts
       switchl.l=fontname
       ttf_font_size=0 ;ttffile=''
       if abbrev(fontname,'!')=1 then do        /* ttf? */
          parse var fontname '!' ttf_font_size '_' ttf_font
       end /* do */
       fontindex='';fontdir=fontname 
       call fix_defaults 1              /* set some default parameters */
       call fix_options
       call check_ndims

       iterate
   end /* do */

   l=l+1
   switchl.l=''

   cls.l=' '              /* the l'th characters GIF file. ''=n.a. */
   cls.!xscale.l=get_user_scale(l,len0,x_scales) /* char specific width scale factor */
   cls.!yscale.l=get_user_scale(l,len0,y_scales) /* char specific height scale factor */
   cls.!xsize.l=0                       /* char width (0=n.a. */
   cls.!ysize.l=0                       /* char height (0=n.a. */
   cls.!char.l=achar
   cls.!isttf.l=0

/* note: xscale and yscale are image independent (uses character position in
  the message, and the user_scale parameter) */
   select

/* ttf font is special */
      when ttf_font_size>0 then do
/* skip through message till next ichar<6 */
        do l00=l0 to len0
          achar2 = substr(amessage,l00,1)
          ichar2=c2d(achar2)
          if ichar2<15 then leave
          isat=l00
        end
        cls.l=substr(amessage,l0,1+isat-l0)
        l0=isat
        utt=strip(translate(ttffile))
        t_file=ttffile
        if abbrev(utt,'HTTP://')=1 then do      /* try to get from www ? */
            if ttffile=was_ttffile then do
                 t_file=gif_dir_root||t_file0
            end /* do */
            else do
               t_file=get_remote_file(ttffile,max_urlsize,verbose,'.FMP',0)
               was_ttffile=ttffile
               t_file0=t_file
               t_file=gif_dir_root||t_file
               nttfs=nttfs+1
            end
        end /* do */
        if t_file<>'' then do 
           fop=stream(t_file,'c','open read')
           rc = rxttf_image(cls.l,t_file,ttf_font_size,ttfdata)
           fop=stream(t_file,'c','close')
           if rc=0  | cls.l='' then do
              cls.!ysize.l=ttfdata.!rows 
              cls.!xsize.l=ttfdata.!cols
              xsize_tot=xsize_tot+cls.!xsize.l
              ysize_tot=ysize_tot+cls.!ysize.l
              cls.!isttf.l=1       
              cfound=cfound+length(cls.l) 
           end
        end
        iterate
      end                               /* ttf */
      when ichar=1 | ichar=2 then do    /* am or pm character */
          achar='PM' ; if ichar=1 then achar='AM'
          cl=get_gifname(achar,gif_dir,fontname)  /* may use UC for LC, etc. */
          if cl=' ' then iterate
      end  /* Do */
      when ichar=3 then do            /* filled box characher */
          cls.l=achar 
          iterate
      end /* do */
      when ichar=4 then do            /* special $x character */
         icss=speclist.!current+1
         speclist.!current=icss
         if icss>speclist.0 then do
            call gpmprintf('GIF_Text warning: special list overrun')
            cls.l=' '
            iterate
         end /* do */
         ichar0=speclist.icss
         if symbol('FONT_IND.!chars.'||ichar0)<>'VAR' then iterate /* no such $nn entry; skip*/
         cl=gif_dir||font_ind.!chars.ichar0
         if stream(cl,'c','query exists')=' ' then iterate  /* no such file */
      end  /* Do */
      otherwise do             /* normal character -- check for file */
         if achar=' ' then iterate
         cl=get_gifname(achar,gif_dir,fontname)
         if cl=' ' then iterate
      end
   end
/* double check -- is it a gif file? */
   im = RxgdImageCreateFromGIF(cl)
   IF (im = 1 | im=0) THEN do
        IF VERBOSE>0 then call gpmprintf("GIF_TEXT bad GIF file: " cl', 'im)
        iterate
   end

   cls.l=cl             /* use the CL gif file for this l'th character 
                         Note: if "complete" or "ttf", should NOT get here */

   cfound=cfound+1

   cls.!xsize.l=RxgdImageSX(im)
   cls.!ysize.l=RxgdImageSY(im)

   xsize_tot=xsize_tot+cls.!xsize.l
   ysize_tot=ysize_tot+cls.!ysize.l
   Call RxgdImageDestroy im
end

len=l   

/* reset original ttf stuff */
ttf_font=ttf_font0
ttf_font_size=ttf_font_size0
ttffile=ttffile0

/* Now, use CLS. and newls to determine HEIGHT AND WIDTH OF MESSAGE */
xmess=(X_FRAME*2) ; ymess=(Y_FRAME*2) ; 
yf2=ymess  /* frames are absolute sizes */


do mm=1 to len          /* note: n.a. characters do not contribute to these calcluations */
    xmess=xmess+trunc(cls.!xsize.mm*cls.!xscale.mm)
    if trunc(yf2+(cls.!yscale.mm*cls.!ysize.mm))>ymess then 
          ymess=yf2+trunc(cls.!yscale.mm*cls.!ysize.mm)
end /* do */

/* adjust for spaces and missing chars (assuming 1 line of text)*/
select
  when cfound=0 then do                 /* no characters found */
        ysize0=def_text_size ; xsize0=def_text_size
        IF FONT_IND.!ndims>0 then DO          /* not generic default, use complete font info */
           xSIZE0=FONT_ind.!WCHAR-(font_ind.!leftoffset+font_ind.!rightoffset)  /*correct for discarded offsets */
           Ysize0=FONT_IND.!HCHAR-(font_ind.!topoffset+font_ind.!bottomoffset)
        END
        do mmm=1 to len            /* fill in CLS. (sort of a stupid approach) */
           cls.!xsize.mmm=xsize0
           cls.!ysize.mmm=ysize0
           xmess=xmess+(xsize0*cls.!xscale.mmm)
           ymess=max(ymess,yf2+trunc(ysize0*cls.!yscale.mmm))
        END
  end  /* Do */

  when len=found then nop               /* all characters found */

  otherwise do                          /* some characters found */
     xavgsize=trunc(xsize_tot/cfound)    /* average size of found characters */
     yavgsize=trunc(ysize_tot/cfound)
     do mmm=1 to len              /* set values for n.a. characters */
        if (cls.mmm<>'' & cls.mmm<>a_box)  then iterate   /* got values, so skip */
        xmess=xmess+(xavgsize*cls.!xscale.mmm)
        cls.!xsize.mmm=xavgsize
        cls.!ysize.mmm=yavgsize
     end /* do */
  end   /* otherwise */

end  /* adjusting size for spaces etc. */


numlines=1 
/* if multiple lines, refigure xmess and ymess; using cls. info */
if newls<>'' then do
   j1=1 ; ymess=0 ; xmess=0 ; numlines=words(newls)+1
   ymess.0=0
   do mm1=1 to numlines         /*recomputing mess width and height */
      xmess.mm1=0 ;ymess.mm1=0
      if mm1=numlines then
         j2=len
      else
         j2=strip(word(newls,mm1))
      do wr=j1 to j2
         xmess.mm1=xmess.mm1+trunc(cls.!xsize.wr*cls.!xscale.wr)
         if trunc(cls.!yscale.wr*cls.!ysize.wr)>ymess.mm1 then 
             ymess.mm1=trunc(cls.!yscale.wr*cls.!ysize.wr)
      end
      xmess=max(xmess,xmess.mm1)
      ymess=ymess+ymess.mm1+line_sep  /* line_sep pixel high line sepeartor */

      j1=j2+1
   end

   ymess.0=ymess
   ymess=ymess+yf2+((numlines-1)*line_sep)            /* character heights + frame */
   xmess.0=xmess
   xmess=xmess+((2*x_Frame))
end /* do */

/* we now know the total image size (xmess and ymess), and the
size/scale/file for each character in the message (cls.) */

/* determine whole  image scale factors, if any */
width_fact=1
height_fact=1
if datatype(width)='NUM' then do   
  if width>0 then do 
      corx=X_OFFSET+(2*x_frame)
      width_fact=(width-corx)/(xmess-corx)   /* will force xmess into frame corrected width */
      xmess=width
  end  /* Do */
end  /* Do */
if datatype(height)='NUM' then do
  if height>0 then do 
     height_fact=(height-yf2)/(ymess-yf2)
     ymess=height
  end  /* Do */
end 

y_useable=ymess-((2*y_frame))  /* height that can be written to */

/* xmess and ymess are the width/height of message (either determined
from message+FRAME, or preset. Width_fact and height_fact will force actual
characters to fit into this rectangle */

/* create a message buffer of required, or desired, size */

   messim=rxgdimagecreate(xmess,ymess)
   if messim=1 | messim=0 then do
      if verbose>0 then  call gpmprintf(" could not create new message buffer ")
      if is_cgi=0 then do
         'NODATA'
         return '400 0'
      end
      else do
           return 
      end /* do */
   end  /* Do */

   if slide<>' ' | slide_size>0 then do                /* if color slide, use seperate back file */
         messim_b=rxgdimagecreate(xmess,ymess)
         if messim_b=1 | messim_b=0 then slide=' '
   end

/* set background color, default text color, and transparent colors */
   oy=rxgdimagecolorallocate(messim,red_back,green_back,blue_back)
   if slide<>' ' | slide_size>0 then  oy=rxgdimagecolorallocate(messim_b,red_back,green_back,blue_back)
 
   if transparent >-1  then do
       call rxgdimagecolortransparent messim,transparent
       if slide_size>0 | slide<>' ' then call rxgdimagecolortransparent messim_b,transparent
   end

/* =-------- fill in the background and the mask? */

call get_background             /* uses globals */

/* background is done; should it be sent as a preliminary version? */
if send_pieces=1 then do
   oof=img_to_var(mmb,tempfile,1)   /* copy image handle to var; signal errdone if problem */
   foo=sref_multi_send(oof,'image/gif','S',,verbose)
   if foo<0  then signal errdone
   send_bim=rxgdimagecreatefromgif(tempfile)
   foo=sysfiledelete(tempfile)
   nsent=1
  if verbose>1 then call gpmprintf(' GIF_TEXT: SENDing background ')
end /* do */

/* create MASK */
call get_mask             /* uses globals */
if send_Pieces=1 & mask_file<>'' then do
   oof=img_to_var(mASKIm,tempfile,1)   /* copy image handle to var; signal errdone if problem */
   foo=sref_multi_send(oof,'image/gif','S',,verbose)
   foo=sysfiledelete(tempfile)
   nsent=1+nsent
end


/* ------ Now copy the appropriate alphabet gifs to the message buffer 
          (or extract from complete font or from ttf font ) */

nowx=x_frame+X_OFFSET ; online=1
nowy=0
if numlines>1 then do
 if line_just='C' | line_just='R' then do       /* center align */
    f1=(xmess.0-xmess.online)/xmess.0 /* diff twixt max width as fraction */  
    gg=1   
    if line_just='C' then gg=2
    f2=f1*xmess/gg                /* scaled back to actual width */
    nowx=nowx+trunc(f2)
 end /* do */
end                     /* 1st of numlines x correction */

do l=1 to len                   /* for each character in "corrected" message */
  if numlines>1 then do
    isl=l-1
    army=wordpos(isl,newls) 
    if army>0 then do           /* new lines, set x and y "line start */
       online=online+1
       nowx=x_frame+X_OFFSET
       if line_just='C' | line_just='R' then do       /* center align */
          f1=(xmess.0-xmess.online)/xmess.0 /* diff twixt max width as fraction */  
          gg=1   
          if line_just='C' then gg=2
          f2=f1*xmess/gg                /* scaled back to actual width */
          nowx=nowx+trunc(f2)
       end /* do */
       ol1=online-1
       nowy=nowy+trunc(((line_sep+ymess.ol1)/ymess.0)*y_useable)
    end /* do */
  end
  if cls.!isttf.l=1 then do
     achar=cls.l
  end /* do */
  else do
     achar=cls.!char.l ; fromdef=0  /* fromdef: 0=own.gif, 1=complete font, 2= generic, 3=ttf */
  end
  uul=l-1
  if switchl.uul<>' ' & uul>0 then do  
       fontname=switchl.uul
       ttf_font_size=0 ;ttffile=''
       if abbrev(fontname,'!')=1 then do        /* ttf? */
          parse var fontname '!' ttf_font_size '_' ttf_font
       end /* do */
       fontindex='';fontdir=fontname 
       call fix_defaults 1              /* set some default parameters */
       call fix_options
       call check_ndims
   end

  if achar=' '  then do          /* a space: skip pixels in image  */
      nowx=nowx+trunc(width_fact*cls.!xscale.l*cls.!xsize.l)
      iterate
  end

  if achar=a_box then do                        /* filled box,  treat as a special "default" character */
      im=rxgdimagecreate(16,16)
      oy=rxgdimagecolorallocate(im,red_back,green_back,blue_back)
      text_color=rxgdimagecolorallocate(im,red_text,green_text,blue_text)
      foo=rxgdimagefilledrectangle(im,0,0,15,15,1)
      xsize=16 ; ysize=16
      fromdef=2
      xsc1=cls.!xsize.l/xsize
      ysc1=cls.!ysize.l/ysize
      cls.!xscale.l=cls.!xscale.l*xsc1
      cls.!yscale.l=cls.!yscale.l*ysc1
      cls.!xsize.l=xsize
      cls.!ysize.l=ysize
  end

  else do                       /* a character */
     cl=cls.l
     if cl=' ' | cls.!isttf.l=1 then     /* n.a. character */
         im=1               /* signal "n.a." .gif file */
     else
        im = RxgdImageCreateFromGIF(cl)
  end

  ichar=32
  if cls.!isttf.l=0 then ichar=c2d(achar)       /* might be speial character */

/*  if no such file, use generic or complete font */
  select

     when (im<=1) & (ichar<10) & (ichar<>3) then do   /* missing special charcter == use space character */
        nowx=trunc(width_fact*cls.!xscale.l*cls.!xsize.l)+nowx
        iterate
     end  /* Do */

     when cls.!isttf.l=1 then do   /* use a ttf font */
        utt=strip(translate(ttffile))
        t_file=ttffile
        if abbrev(utt,'HTTP://')=1 then do      /* try to get from www ? */
           if nttfs>1 then do
              t_file=get_remote_file(ttffile,max_urlsize,verbose,'.FMP',0)
              t_file=gif_dir_root||t_file
           end          /* else, we already read it above */
           else do
              t_File=gif_dir_root||t_file0
           end /* do */
        end /* do */
        if t_File='' then do
             fromdef=3
             iterate
        end /* do */
        im=create_ttf_gif(achar,t_file,ttf_font_size)  /* t_file set when "sizing */
        fop=stream(t_file,'c','close')

         xsize=RxgdImageSX(im)      /* complete font (useable) size */
         ysize=RxgdImageSY(im)  
         fromdef=3
     end /* do */
     

     when im <= 1  THEN   do       /* missing, use generic or DEFAULT font */
        uul=l-1
   
        im=get_default_char(achar,l,len,many_type_max)   /* alphabyte specific default? */

        if im<>1 then do    /* got an image containing the font */
          if  verbose>1 then call gpmprintf(' GIF_TEXT: using alphabyte specific default for character ' achar)
          xsize=RxgdImageSX(im)      /* complete font (useable) size */
          ysize=RxgdImageSY(im)  
          fromdef=1
        end

        else do         /* no complete font -- use generic default */
          if  verbose>1 then call gpmprintf(' GIF_TEXT: using default for character ' achar)
          im=rxgdimagecreate(16,16)
          oy=rxgdimagecolorallocate(im,red_back,green_back,blue_back)
          text_color=rxgdimagecolorallocate(im,red_text,green_text,blue_text)
          foo=rxgdimagestring(im,'G',0,0,achar,text_color)
          xsize=16 ; ysize=16
          fromdef=2
        end

/* scale must scale xsize,ysize to presumed size (cls.!xsize,!ysize);
  and still include character specific scale */
        xsc1=cls.!xsize.l/xsize
        ysc1=cls.!ysize.l/ysize
        cls.!xscale.l=cls.!xscale.l*xsc1
        cls.!yscale.l=cls.!yscale.l*ysc1
        cls.!xsize.l=xsize
        cls.!ysize.l=ysize
     end

     otherwise  do               /* use matching .gif file */
        xsize=cls.!xsize.l
        ysize=cls.!ysize.l
        fromdef=0
     end

  end           /* select */

/* copy to message buffer. Rxgd will take care of color table matching, etc */

/* fix background & transparency */
  foo=0
  if back_File<>' '& fromdef>0  & transparent>-1 then do
    tt=transparent
    if font_ind.!isbw=0 then do
       tt=rxgdimagecolorclosest(im,dim_r,dim_g,dim_b)
    end
    call rxgdimagecolortransparent im,tt
    foo=tt
  end
  else do
   if back_file<>' ' then foo=rxgdimagegettransparent(im)
  end
  if foo=-1 & back_file<>" " & fromdef=0 then do   /* try to fix transparency */
     call rxgdimagecolortransparent im,font_ind.!transparent
  end


/* now, write possibly scaled image to messim.  There are two scales:
  character specific scale: a combo of the "generic/default to average"
                            and the "user-specified character specific scale"
  whole message scale: fit message to specified message width/height
  and ... adjust vert and horiz for line and line alignment 
*/

  wfact=width_fact*cls.!xscale.l
  hfact=height_fact*cls.!yscale.l
  xsize=cls.!xsize.l ; ysize=cls.!ysize.l
  yff=y_frame+y_offset
  ish=y_useable
  if numlines>1 then ish=trunc(((line_sep+ymess.online)/ymess.0)*y_useable)

  if wfact=1 &hfact=1 then do
      select
         when y_valign='B' then do
              yff=yff+(ish-ysize)
         end  /* Do */
         when y_valign='M' then do
              yff=(y_offset+y_frame)+((ish-ysize)/2)
         end  /* Do */
         otherwise nop
      end  /* select */

      foo=rxgdimagecopy(messim,im,nowx,nowy+yff,0,0,xsize,ysize)
      nowx=nowx+xsize
  end
  else do   /* scale it */
      dxsize=trunc(xsize*wfact)
      dysize=trunc(ysize*hfact)
      ish=y_useable
      if numlines>1 then ish=trunc(((line_sep+ymess.online)/ymess.0)*y_useable)
      select
         when   y_valign='T' then yff=y_frame+y_offset
         when y_valign='B' then do
              yff=y_offset+y_frame+(ish-dysize)
         end  /* Do */
         when y_valign='M' then do
              yff=y_offset+y_frame+((ish-dysize)/2)
         end  /* Do */
         otherwise yff=y_offset+y_frame
      end  /* select */
      foo=rxgdimagecopyresized(messim,im,nowx,nowy+yff,0,0, ,
                               dxsize,dysize,xsize,ysize)
      nowx=nowx+dxsize
  end  /* Do */

  Call RxgdImageDestroy im

end             /* l'th character of message */

/* if slide used, slideify messim, and then copyit to messim_b */

/* message is done; should it be sent as a secondary version? */
if send_pieces=1 & (slide<>"" | slide_size>0 | mask_file<>'') then do
   foo=rxgdimagecopy(send_bim,messim,0,0,0,0,xmess,ymess) 
   oof=img_to_var(send_bim,tempfile)
   foo=sref_multi_send(oof,'image/gif','M')
   if foo<0 then signal errdone
   nsent=2
   if verbose>1 then call gpmprintf(' GIF_TEXT: SENDing message text ')
end /* do */

/* get first row of slide, and fix up color table */
if slide<>' ' then do              /* read slide from file */
   if is_cgi=0 & abbrev(strip(translate(slide)),'HTTP://')=1 then do /* remote slide */
      slim=0
      bslide=get_remote_file(slide,max_urlsize,verbose,'.SMP')
      if bslide<>'' then do
          slim=rxgdimagecreatefromgif(gif_dir_root||bslide)
          fo=sysfiledelete(gif_dir_root||bslide)
      end /* do */
   end /* do */
   else do
      slim=rxgdimagecreatefromgif(slide)
   end
   if (slim=0 | slim=1 )  then do
          slide=''              /* no slide avaialble */
          if verbose>1 then 
             call gpmprintf(' No Slide file available ')
   end  /* Do */
end  /* Do */

if slide="" & slide_size>0 then do   /* make your own slide */
   slidect.0=slide_size ; slide.0=slide_size
   do mm=1 to slide_size
      mm0=mm-1
      slidect.!r.mm0=map255(get_user_scale(mm,slide_size,slide_red))
      slidect.!g.mm0=map255(get_user_scale(mm,slide_size,slide_green))
      slidect.!b.mm0=map255(get_user_scale(mm,slide_size,slide_blue))
      slide.mm=mm-1
   end /* do */
   slide_vert='N'       /* force it to be "one row" color slide */
   foo=grab_slide(0,slide_horiz,xmess,1,ymess,,slide_xcoord,slide_ycoord)
end

/* valid color slide .gif file, so get the slide */
if slide<>' ' | slide_size>0 then do

   if slide<>' ' then do   /* get slide just once */
       foo=grab_slide(slim,slide_horiz,xmess,0,ymess,,slide_xcoord,slide_ycoord)
       foo=rxgdimagecolorstotal(slim)

/* read the color slide's color table,*/
       foo=rxgdimagegetcolortable(slim,'tt')
       r='R'; g='G'; b='B'
       slidect.0=tt.0
       do il=0 to slidect.0-1
          slidect.!r.il=tt.r.il
          slidect.!g.il=tt.g.il
          slidect.!b.il=tt.b.il
       end
    end

/* if slide_size>0, then we use slidect that was created above */

/* get color table of messim (if slide_thresh_type<>'P') */
   if slide_thresh_type<>'P' then do
      foo=rxgdimagegetcolortable(messim,'tt')
      r='R'; g='G'; b='B'
      messct.0=tt.0
      do il=0 to messct.0-1
        messct.!r.il=tt.r.il
        messct.!g.il=tt.g.il
        messct.!b.il=tt.b.il
      end
   end /* do */

   foo=add_slide_ct(messim)             /* add/remapslide colors to message image */
   if slide_xcoord<>'' & slide_Ycoord<>'' then do
       ixcoord=slide_xcoord*xmess ; iycoord=slide_ycoord*ymess
   end
   nchanges=0
   if slide_prob="" then do
       ixcoord=0 ; iycoord=ny
   end /* do */

/* Get each row of message image, check and (possibly) convert each pixel to slide colors */
   hey=time('r')                /* timer used for SEND */

   nofinal=0            /* a special effect -- causes a left side shadow */
   if send_pieces=1 & wordpos('NOFINAL',translate(special))>0 then nofinal=1
   do ny=0 to ymess-1           /* =========== for each row of message image */
     if slide_coord="" then do
         ixcoord=0 ; iycoord=ny
     end /* do */
     if verbose>1 & ny//25=1 &send_pieces<>1 then call gpmprintf(" GIF_TEXT: Transforming message row " ny ' of ' ymess)
     if slide_vert<>'N' then do
        foo=grab_slide(slim,slide_horiz,xmess,ny,ymess,slide_vert)      /* get slide for this rowl */
     end  /* Do */
     foo=rxgdimagegetrowpixels(messim,ny,pxels)

/* save some processing by not messing with masked pixels */
      if mask_file<>' ' then do          /* mask this */
           foo=rxgdimagegetrowpixels(maskim,ny,maskpxels)
       end /* do */

/* ========= now scan "message" image, and modify pixels using color slide */
     do nx=1 to xmess
       apix=pxels.nx

/* masked, then skip */
       if mask_file<>'' then do /* check the mask */
          if maskpxels.nx=0 then iterate
       end

       if slide_thresh="P1" & apix=0 then iterate  /* the most common case */
       doit=do_change(apix,slide_thresh_type,slide_thresh_val,nx,xmess)
       if doit=1 then do
           if (slide_xcoord="" | slide_ycoord="") & slide_prob="" then do
               itmp=slide.nx
           end
           else do
               nnx=max(1,trunc(figdist(nx,ny,ixcoord,iycoord)))
               doit=do_change(1,'P',1,nnx,slide.0,slide_prob,1)  /* check probability */
               if doit=0 then iterate 
               itmp=slide.nnx
           end /* do */
           apix=slidect.!alt.itmp ; nchanges=nchanges+1
        end  /* Do */
        pxels.nx=apix
     end
     drop pxels.0

      styled  = RxgdImageSetStyle(messim, pxels, xmess)         /* write transformed row back to */
      rc = RxgdImageLine(messim, 0,ny,xmess-1,ny,styled)        /*  the message image */

     if send_pieces=1 then do            /* SEND what ya got? */
           hey2=time('e')
           if hey2>send_delay | (nofinal=1 & ny=ymess-1) then do
                foo=rxgdimagecopy(send_bim,messim,0,0,0,0,xmess,ymess) 
                oof=img_to_var(send_bim,tempfile)
                foo=sref_multi_send(oof,'image/gif','M')
                if foo<0 then signal errdone
                nsent=nsent+1
                if verbose>1 then call gpmprintf(' GIF_TEXT: SENDing transformed message text ' ny ' of 'ymess)
                hey=time('r')
           end /* do */
     end /* do */

   end              /* transforming row ny */
   if  nofinal=1 then
      foo=rxgdimagecopy(messim_b,send_bim,0,0,0,0,xmess,ymess)  /* final copy */
   else
      foo=rxgdimagecopy(messim_b,messim,0,0,0,0,xmess,ymess)  /* final copy */
   mmb=messim_b

end  /* Do */

else do                 /* no color slide */
    mmb=messim
end


/* and finally, apply  mask */
if mask_file<>' ' then do          /* mask this */
   do ny=0 to ymess-1           /* for each row of message image */
    foo=rxgdimagegetrowpixels(mmb,ny,pxels)
    foo=rxgdimagegetrowpixels(maskim,ny,maskpxels)
    do nx=1 to xmess
       apix=pxels.nx*maskpxels.nx
       PXELS.NX=APIX
    end
    drop pxels.0
    styled  = RxgdImageSetStyle(mmb, pxels, xmess)         /* write transformed row back to */
    rc = RxgdImageLine(mmb, 0,ny,xmess-1,ny,styled)        /*  the message image */
  END
  foo= RxgdImageDestroy(maskim)
end

/* copy buffer to a file, and clean up */
if do_cache=0 then do
  gif_file=gif_dir_root||"MES?????.GIF"
  gfile=systempfilename(gif_file)
end
else do
   gfile=gif_dir_root||cache_file
end


foo=rxgdimagegif(mmb,gfile)

foo= RxgdImageDestroy(messim)
if slide<>' ' then foo= RxgdImageDestroy(messim_b)
do mm1=1 to font_ind.!ndims
  jdim=dim.mm1
  foo= RxgdImageDestroy(jdim)
end /* do */

if send_bim<>0 then foo=rxgdimagedestroy(send_bim)
if slide<>' ' then foo=rxgdimagedestroy(slim)
IF VERBOSE>1 then CALL GPMPRINTF(' GIF_TEXT: completed image of size ' xmess ' x ' ymess )

shipit: nop             /* jump here if cache entry found */

if is_cgi=0 then do             /* srefilte addon */
  signal on failure name nocon
  if send_pieces=1 then do            /* final send? */
      oof=charin(gfile,1,chars(gfile))
      foof=stream(gfile,'c','close')
      foo=sref_multi_send(oof,'image/gif','E')
      ieek=stream(gfile,'c','query size')
      if do_cache=0 then   foo=sysfiledelete(gfile)
      if foo<0  then signal errdone
      nsent=3
      return 200' 'ieek
  end /* do */
/* else, use 'FILE  */
  if do_cache=0 then do
     return 'FILE ERASE TYPE image/gif name ' gfile     /* let sre deal with reply */
   end
   else do
     return 'FILE  TYPE image/gif NOCACHE name ' gfile
   end
   oof=stream(gfile,'c','query size')
   return '200 '||oof
end
if is_cgi=1 then do             /* cgi-bin */
  ki=chars(gfile); foo=stream(gfile,'c','close')
  foo=charin(gfile,1,ki) 
  foo2=stream(gfile,'c','close')
  if fake_cgi=0 then do
     Say "Content-type: image/gif"
     Say
  end
  else do
     say "Writing "||length(foo)||" bytes to GIF file: " outputfile
  end
  if fake_cgi=1 then            /* command line invocation with parameters on command line */
     call charout outputfile,foo
  else
     call charout,foo
  if result<>0 then 
     call gpmprintf(" GIF_TEXT CGI-BIN error: not all of file written: "||foo3)
  if do_cache=0 then  foo=sysfiledelete(gfile)
  return 
end /* do */

if is_cgi=2  then do            /* stand alone */
  foo2=stream(gfile2,'c','close')
  ki=stream(gfile,'c','query size')
  foo=charin(gfile,1,ki) 
  aa=charout(gfile2,foo,1)
  IF AA>0 then 
      SAY " Problem writing to outfile: " gfile2
  else
     say gfile2 " created (length = " ||stream(gfile2,'c','query size')
  foo=stream(gfile2,'c','close')
  foo=stream(gfile,'c','close')

   IF YESNO(' Display this image using '||img_prog) =1 then do
       oo=stream(gfile2,'c','query exists')
       ar1=translate(oo,':','|')
       ar1=translate(ar1,'/','\')
       foo=img_prog' file:///'||ar1
       '@start /f 'foo
       say cy_ye " >>> starting "img_prog ||normal" (it might take a few seconds...)"
   end                  /* display with "img_prog" */

  foo=sysfiledelete(gfile)

   exit
end  /* Do */


errdone:
if is_cgi=1 then do
  Say "Content-type: text/plain"
  Say
  say "GIF_TEXT error at line  " sigl " (RC=" rc
  return 
end /* do */

say "GIF_TEXT error at line  " sigl " (RC=" rc
if is_cgi=0 then do
   'NODATA'
   return  '400 0'
end
exit

/***************/
/* get the background file */
get_background:


mmb=messim 
if back_file=0 then back_file=' '
if back_file='' then return 0
kill_backfile=0

if is_cgi=0 & abbrev(translate(back_file),'HTTP://')=1 then do /* try to get url? */
  back_file=get_remote_file(back_file,max_urlsize,verbose,'.GMP')
  if back_file='' then return 0
end

back_file=strip(translate(back_file,'\','/'),,'\')
bf2=back_file
back_file=stream(gif_dir_root||back_file,'c','query exists')
if back_file=""  & pos(".gif",bf2)=0 then
   back_file=stream(gif_dir_root||bF2||'.gif','c','query exists')


if back_file='' then return 0

if slide_size>0 | slide<>' ' then mmb=messim_b   /* where to write background */

/* now we write a background image */
if back_file<>' ' then do
  foo=tile_image(mmb,back_file,back_scale,xmess,ymess)
  if kill_backfile=1 & foo>0 then foo=sysfiledelete(back_file) /* kill temporary backg file */
end

return 1



/***************/
/* get the mask file */
get_mask:

if mask_file=0 then mask_file=''
if mask_file='' then return 0

/* pull off the www? */
kill_maskfile=0
if is_cgi=0 & abbrev(translate(mask_file),'HTTP://')=1 then do /* try to get url? */
  mask_file=get_remote_file(mask_file,max_urlsize,verbose,'.GMP')
  if mask_file='' then return 0
end

mask_file=strip(translate(mask_file,'\','/'),,'\')
tmpname=mask_file
mask_file=stream(gif_dir_root||mask_file,'c','query exists')
if mask_file="" & pos(".gif",tmpname)=0 then
   mask_file=stream(gif_dir_root||tmpname||'.gif','c','query exists')

if mask_image=' ' then return 0

maskim=rxgdimagecreate(xmess,ymess)
if maskim=0 | maskim=1 then do
    call gpmprintf(' GIF_text: unable to create mask image ')
    return 0
end /* do */

/* now we write a mask image */
foo=tile_image(maskim,mask_file,mask_scale,xmess,ymess)
if kill_maskfile=1 & foo>0 then foo=sysfiledelete(mask_file) 

/* convert to 0/1 mask */
do ny=0 to ymess-1           /* for each row of message image */
   foo=rxgdimagegetrowpixels(maskim,ny,maskpxels)
   do nx=1 to xmess
       apix=1           /* assume its not masked */
       if mask_reverse>0 then do  /* high pixels are masked " */
          if maskpxels.nx>mask_threshold then apix=0
       end
       else do               /* low pixels are masked */                   
         if maskpxels.nx<=mask_threshold then apix=0
       end
       maskPXELS.NX=APIX
   end
   drop maskpxels.0
   styled  = RxgdImageSetStyle(maskim, maskpxels, xmess)         /* write transformed row back to */
   rc = RxgdImageLine(maskim, 0,ny,xmess-1,ny,styled)        /*  the message image */
end

foo=rxgdimagecolordeallocate(maskim,0)
oy1=rxgdimagecolorallocate(maskim,0,0,0)
foo=rxgdimagecolordeallocate(maskim,1)
oy2=rxgdimagecolorallocate(maskim,155,155,155)


return 1




/***********/
check_ndims:
/* check on default font info */
font_ind.!ndims=0
if font_ind.!defgifs<>' ' then do
   do wiww=1 to words(font_ind.!defgifs)
 
      adefgif=strip(word(font_ind.!defgifs,wiww))
      bdefgif=gif_dir||adefgif
      dim= RxgdImageCreateFromGIF(bdefgif)
      if dim=1 | dim=0 then do
           CALL gpmprintf(' GIF_TEXT: missing alphabyte specific default:'adefgif)
           iterate
      end
      ndims=ndims+1
      att=transparent ; if att<0 then att=0
      dim.ndims=dim
      dim.ndims.!name=adefgif
      if ndims=1 then do
         dim_r=rxgdimagered(dim,att)
         dim_g=rxgdimagegreen(dim,att)
         dim_b=rxgdimageblue(dim,att)
      end

  end  /* Do */
  font_ind.!ndims=ndims
end  /* Do */
return 1

/******************/
/* copy an image to a variable (copy of what would be in .gif file */
img_to_var:procedure expose tempfile is_cgi
parse arg im,afile,keepit
if afile=""  then afile=tempfile
foo1=rxgdimagegif(im,afile)
oof=charin(afile,1,chars(afile))
if oof="" then signal errdone           /* empty -- must be aproblem */
foo=stream(afile,'c','close')
if keepit<>1 then foo=sysfiledelete(afile)
return oof


/*********************/
/* get a remote gif file */
get_remote_file:procedure expose gif_dir_root verbose crlf

parse arg aurl,mxs,vv,anext,checkfor

if checkfor='' then checkfor='IMAGE/GIF'
goo=get_url(aurl,mxs,vv)

if goo=0 then do 
      call gpmprintf('GIF_TEXT: Can not get remote  file: 'aurl)
      return ''
end /* do */
parse var goo alin (crlf) goo
parse var alin . astat . ; astat=strip(astat)
if abbrev(strip(astat),'2')<>1 then do
   call gpmprintf('GIF_Text: URL not available (code='astat)
   return ' '
end /* do */
do forever
   parse var goo alin (crlf) goo
   if alin='' then leave         /* now we should have the beginining of the image */
   parse upper var alin ahead aheadv
   if checkfor=0 then iterate
   if strip(ahead)<>'CONTENT-TYPE:' then iterate
   if strip(aheadv)<>checkfor then do
      call gpmprintf('GIF_Text: URL bad content-type :'aheadv)
      return ' '
   end /* do */
end

a_file=dospid()||'$'||dostid()||anext  /* save image to file */
afoo=stream(gif_dir_root||a_file,'c','query exists') /* zap eariler versions ? */
if afoo<>'' then do             /* exists, try to delete */
   foo3=sysfiledelete(gif_dir_root||a_file)
   if foo3<>0 then do                            /* could not delete, use temp file name */
        a_file=left(dospid()||'$'||dostid(),8,'?')||anext
        a_file=systempfilename(a_file)
   end
   if a_file='' then do         /* could not make temp file name */
         call gpmprintf('GIF_Text: could not make temporary file: ' foo)
         return ''
   end
end

foo=charout(gif_dir_root||a_file,goo,1)

if foo<>0 then do
  call gpmprintf('GIF_Text: could not write 'gif_dir_root||a_file)
  return ''
end
foo=stream(gif_dir_root||a_file,'c','close')
if verbose>2 then call gpmprintf('GIF_TEXT: saving remote image to 'a_file)

return a_file



/* ---------------------------------------------*/
/* get a url from some site, return first
maxchar characters (if maxchar missing, get 10million (the whole thing?) */
/* ---------------------------------------------*/
get_url:
parse arg aurl,maxchar,verbose,headers

if maxchar="" then maxchar=10000000
got=""

if abbrev(translate(aurl),'HTTP://')=1 then do
   aurl=substr(aurl,8)
end
parse var aurl server '/' request

if VERBOSE>0 then call gpmprintf( "GIF_Text: calling http url : " server ", " request)

/* Load RxSock */
if \RxFuncQuery("SockLoadFuncs") then nop
else do
       call RxFuncAdd "SockLoadFuncs","rxSock","SockLoadFuncs"
       call SockLoadFuncs
end

crlf    ='0d0a'x                        /* constants */
family  ='AF_INET'
 httpport=80

rc=1
if verify(server,'1234567890.')>0 then 
       rc=sockgethostbyname(server, "serv.0")  /* get dotaddress of server */
else
      serv.0addr=strip(server)

if rc=0 then do
        ss=sref_error('Unable to resolve "'server'"',verbose)
        return 0
end
 dotserver=serv.0addr                    /* .. */
 gosaddr.0family=family                  /* set up address */
  gosaddr.0port  =httpport
 gosaddr.0addr  =dotserver

    gosock = SockSocket(family, "SOCK_STREAM", "IPPROTO_TCP")

    /* Set up request [HTTP 1.0, with HOST: header] */
    message="GET /"request' HTTP/1.0 'crlf
    if length(headers)>2 then do
       if right(headers,2)=crlf then headers=left(headers,length(headers)-2)
    end
    if headers<>'' then message=message||headers||crlf
    message=message||'Host: 'server||crlf
    message=message||crlf

    got=''
    rc = SockConnect(gosock,"gosaddr.0")
    if rc<0 then do
        ss=sref_error(' Unable to connect to "'server'"',verbose)
        return 0
    end
    rc = SockSend(gosock, message)

/* Now wait for the response */

   do r=1 by 1
     rc = SockRecv(gosock, "response", 1000)
     got=got||response
     if rc<=0 then leave
     tmplen=length(got)
     if tmplen> maxchar then leave
  end r

  rc = SockClose(gosock)

return got



/************************/
/* fill gif image mmb with imb, using tiles or stretching */
tile_image:procedure expose verbose
parse arg mmb,back_file,back_scale,xmess,ymess

imb = RxgdImageCreateFromGIF(back_file)
IF (imb = 1 | imb=0) THEN do
   IF VERBOSE>0 then call gpmprintf("GIF_TEXT bad GIF backfile: " back_file', 'imb)
   return 0
end

srcw=RxgdImageSX(imb)
srch=RxgdImageSY(imb)

if back_scale>0 then do     /* scale image to fit into box */
          srcw=RxgdImageSX(imb)
          srch=RxgdImageSY(imb)
          foo=rxgdimagecopyresized(mmb,imb,0,0,0,0,xmess,ymess,srcw,srch)
          return 0
end  /* Do */

 h1=trunc(xmess/2)+1  ; w1=trunc(ymess/2)+1
 select 
     when srcw>xmess & srch > ymess  then do   /* image smaller then backg */
              x0=trunc((srcw-xmess)/2) ; y0=trunc((srch-ymess)/2)
              fpp=rxgdimagecopy(mmb,imb,0,0,x0,y0,xmess,ymess)
     end

     when srcw<=xmess & srch<=ymess then do
              xstart=0
              do forever                /* go across (do a column) */
                 jjjx=min(srcw,(xmess-xstart))  /* width of this column */
                 ystart=0
                 do forever                /* go down (do a row) */
                   jjjy=min(srch,(ymess-ystart))
                   fpp=rxgdimagecopy(mmb,imb,xstart,ystart,0,0,jjjx,jjjy)
                   ystart=ystart+srch
                   if ystart>=ymess then leave
                 end
                 xstart=xstart+srcw
                 if xstart>=xmess then leave
              end
     end /* do */

     when srcw>xmess  then do  /* back wider then image */
              ystart=0
              fpp=rxgdimagecopy(mmb,imb,0,0,0,0,xmess,srch)
              do forever
                 ystart=ystart+srch
                 jjj=min(srch,(ymess-ystart))
                 if jjj<1 then leave
                 fpp=rxgdimagecopy(mmb,imb,0,ystart,0,0,xmess,jjj)
              end

    end

    when  srch>ymess then do   /* backg higher then image */
              xstart=0
              fpp=rxgdimagecopy(mmb,imb,0,0,0,0,srcw,ymess)
              do forever
                 xstart=xstart+srcw
                 jjj=min(srcw,(xmess-xstart))
                 if jjj<1 then leave
                 fpp=rxgdimagecopy(mmb,imb,xstart,0,0,0,jjj,ymess)
              end
    end /* do */

   otherwise nop
end

oy=rxgdimagecolorstotal(mmb) 
if verbose>1 then do
   call gpmprintf(' GIF_TEXT: # of colors in  ('bacK_file') = ' oy)
end

foo=rxgdimagedestroy(imb)
return oy



/**************************************************/
/* set/cleanup DEFAULT parametrs */
fix_defaults:
parse arg nocheck

nsent=0
kill_slidefile=0

if back2_file<>0 & back2_file<>'' then
    back_file=strip(back2_file)          /* usedto allow type="TEXT" override in mkgiftxt*/

if fontdir2<>'' & fontdir2<>0 then fontdir=fontdir2

if mask_threshold=''  | datatype(mask_threshold)<>'NUM' then mask_threshold=0

crlf='0d0a'x

red_text=100 ;green_text=100 ; blue_text=100
red_back=255 ; green_back=205 ; blue_back=155

def_transparent=check_byte(def_transparent,-1)
def_text_size=check_byte(def_text_size,15)
if fontname=0 then fontname=' '
if fontindex=0 then fontindex=' '
if back_file=0 then back_File=' '

gif_dir=gif_dir_root||strip(fontdir,,'\')||'\'

/* check the cache? */
if nocheck<>1 then do
  if do_cache=1 then
    if pos('$D',translate(amessage))+pos('$T',translate(amessage))>0 then do_cache=0
  if cache_size=0 then do_cache=0

  /* use a cached file? */
  foo=do_from_cache(cache_file)

  if foo=1 then do   
     send_pieces=0
     return 2
  end
end

ttffile=ttf_font
if ttf_font_size>0  & abbrev(strip(Translate(ttf_font)),'HTTP://')=0 then do
  arg=ttf_dir_root||ttf_font
  ttffile=stream(arg,'c','query exists')
  if ttffile='' & pos('.',ttfile)=0 then do
     arg=ttf_dir_root||ttf_font||'.ttf'
     ttffile=stream(arg,'c','query exists')
   end
end
else do
  oof=translate(fontdir,'  ','\/')
  if fontname=' ' then fontname=strip(word(oof,words(oof)))
  if fontindex=' ' then fontindex=fontname||'.IND'
  fontindex=gif_dir||fontindex
  dim=0 ; ndims=0;font_ind.!defgifs=' '
  dim_r=0;  dim_g=0 ; dim_b=0
end


return 1



/***************************/
/* set options, using font_index and request stuff */
fix_options:
/* get font index, and possibly  text and back colors and default-font info */

inind=READ_FONT_INDEX(fontindex)  /* read in font index, and back and text color_index*/
if textcolor="" then textcolor=font_ind.!textcolor
if backcolor="" then backcolor=font_ind.!backcolor

vvs=get_from_hex(textcolor)
if vvs<>' ' then do
      parse var vvs red_text green_text blue_text
end  

vvs=get_from_hex(backcolor)

if vvs<>' ' then do
      parse var vvs red_back green_back blue_back
end  /* Do */

if ttffile=''  then do

/* many_complete from options ? */
   if many_type>0 then font_ind.!manytype=many_type

/* if no x_scales or y_scales in request, use .IND file (if exists) */
   if x_scales<>"" then font_ind.!x_user_scale=x_scales
   if y_scales<>"" then font_ind.!y_user_scale=y_scales
   x_SCALES=FIX_SCALE(FONT_IND.!X_USER_SCALE)
   Y_SCALES=FIX_SCALE(FONT_IND.!Y_USER_SCALE)

   if y_valign="" then y_valign=font_ind.!y_valign
end

y_valign=translate(y_valign)
select
  when abbrev(y_valign,'B')=1 then y_valign='B'
  when abbrev(y_valign,'T')=1 then y_valign='T'
  when abbrev(y_valign,'M')+abbrev(y_valign,'C')>0 then y_valign='M'
  otherwise y_valign='T'
end

if ttffile='' then do
  if slide_vert="" then slide_vert=font_ind.!slide_vert
end

/* slide_vert= Tile, Fit, None */
slide_vert=left(strip(translate(slide_vert)),1)
if pos(slide_vert,'TFN')=0 then slide_vert='N'  /* use 1 slide is default */

if slide_horiz="" then slide_horiz=font_ind.!slide_horiz
slide_horiz=left(strip(translate(slide_horiz)),1)
/* slide_horiz types: Tile. Resize */

if slide2<>'' then slide=slide2

if slide="" & ttffile='' then slide=font_ind.!slide

if slide<>'' & abbrev(strip(translate(slide)),'HTTP://')=0 then do
  if slide2<>'' then slide=gif_dir_root||slide2
   stmp=slide
   slide=stream(slide,'c','query exists')
   if  slide=' ' & pos('.',stmp)=0 then do  /* try adding .gif to end */
       slide=stream(stmp||'.gif','c','query exists')
   end  /* Do */
end  /* Do */

if slide_thresh="" & ttffile='' then slide_thresh=font_ind.!slide_thresh
slide_thresh=translate(strip(slide_thresh))
slide_thresh_type=left(slide_thresh,1)
slide_thresh_val=substr(slide_thresh,2)
slide_thresh_val=strip(translate(slide_thresh_val,' ','+:'))  /* might be list of values */

if slide_size=""  & ttffile='' then  slide_size=font_ind.!slide_size
if slide_size<>0 then do
  if slide_green="" then  slide_green=font_ind.!slide_gre en
  if slide_red="" then  slide_red=font_ind.!slide_red
  if slide_blue="" then  slide_blue=font_ind.!slide_blue
  slide_green=fix_scale(slide_green)
  slide_red=fix_scale(slide_red)
  slide_blue=fix_scale(slide_blue)
end

if slide_prob="" & ttffile='' then slide_prob=font_ind.!slide_prob
slide_prob=fix_scale(slide_prob)

if slide_coord="" & ttffile='' then slide_coord=fonT_ind.!slide_coord
slide_coord=fix_scale(slide_coord)  
parse var slide_coord tx ty
if datatype(tx)='NUM' & datatype(ty)='NUM' then do
        slide_xcoord=tx
        slide_ycoord=ty
end /* do */
if pos(slide_thresh_type,'PCB')=0  then do
     slide=''
     call gpmprintf(' Error1 specifying slide_thresh:'slide_thresh)
end  /* Do */
do ll=1 to words(slide_thresh_val)
  if datatype(strip(word(slide_thresh_val,ll)))<>'NUM' then do
     slide=''                                                        
     call gpmprintf(' Error2 specifying slide_thresh:'slide_thresh)   
  end
end

if verbose >1 & slide<>' ' then  do
  call gpmprintf(" GIF_TEXT: Using color slide " slide)
end
else do
  if verbose >1 & slide_size>0  then call gpmprintf(" GIF_TEXT: Using generated color slide, #colors=" slide_size)
end

/* what's the "transparent" color table entry */
if transparent='' then    /* not specified in request */
    transparent=font_ind.!transparent
if transparent>255 | transparent <-1 then transparent=def_transparent /* is it copecetic? */

return 1


/**************************************/
/* fix up message */
/* convert $x into time, date, etc. */
fix_message:
user_fonts=''
speclist.0=0
speclist.!current=0
goof='00'x
aa=translate(amessage,goof,'0d0a09'x)
aaa=''
do until aa=""
   parse var aa a1 (goof) aa
   aaa=aaa||a1
end /* do */
amessage=aaa
if literal<>1  & pos('$',amessage)<>0 then do
/* parse amessage, converting $x into appropriate stuff. Note that $$ (or $$$..)
   is interpreted at $ (or $$...) */
  newmess=""
  m2=amessage
  do until amessage=""
       parse var amessage m1 '$' m2
       newmess=newmess||m1
       if m2="" then leave
       if abbrev(m2,'$')=1 then do  /* strip out $ and display */
          amessage=strip(m2,'l','$')
          idls=length(m2)-length(amessage)
          newmess=newmess||copies('$',idls)
          iterate
       end  
       akey=translate(left(m2,1))
       select
          when  akey='T' then newmess=newmess||get_time(time_fmt)
          when  akey='D' then newmess=newmess||get_date(date_fmt)
          when  akey='S' then newmess=newmess||'SERVERNAME'
          when akey='#' then do
            parse var m2 ains ';' m2
            ains=strip(ains,,'#')    
            ains=translate(strip(ains))
            if right(ains,1)='X' then do
              ains=strip(ains,'t','X')
              ains=x2d(ains)
            end
            if datatype(ains)='NUM' then do
                newmess=newmess||d2c(ains)
            end
            amessage=m2
            iterate                            
          end /* do */
          when pos(akey,'1234567890')>0 then do
             rval=akey
             akey2=translate(substr(m2,2,1))
             if pos(akey2,'1234567890')>0 then do
                 rval=(rval*10)+akey2
             end
             newmess=newmess||d2c(4) /* 4 signals "special character" (referenced in speclist) */
             isss=speclist.0+1
             speclist.isss=rval
             speclist.0=isss
             amessage=substr(m2,length(rval)+1)
             iterate
          end
          when akey='B' then  newmess=newmess||d2c(3) /* 3 is "filled box " */
          when akey='N' then  newmess=newmess||d2c(10)  /* line break */
          when akey='F' then do
               parse var amessage . '(' newfont ')' amessage
               user_fonts=user_fonts||' 'newfont
               newmess=newmess||d2c(6)          /* 6 signals "font switch */
               iterate
          end /* do */
          otherwise nop
       end
       amessage=substr(m2,2)
  end /* do */
  amessage=newmess
end  /* interpret $x */
return 1

/***********************************/
/* map a 0.. 1 to 0..255 */
map255:procedure
parse arg a1
return trunc(max(min(a1*255,255),0))

/***********************************/
/* change this pixel ? */
do_change:procedure expose messct. is_cgi
parse arg apix,atype,aval0,jjx,xlen,slide_prob,useaval,jjy
if useaval=1 then
  aval=aval0
else
  aval=get_user_scale(jjx,xlen,aval0) /* pixel specific threshold */

aprob=get_user_scale(jjx,xlen,slide_prob)   /* probability of using scale: 1- always use,0-use original value*/
if aprob<1 then do
   arf=random()/999
   if arf>aprob then return 0           /* retain with current value */
end /* do */

if atype='P' then do
   if apix >= aval then return 1
   return 0
end  /* Do */
r=messct.!r.apix
b=messct.!b.apix
g=messct.!g.apix
if atype='C' then do            /* if brightest color is over threshold */
    if max(r,b,g)>=aval then return 1
    return 0
end  /* Do */
if atype='B' then do            /* if average brightness over threshold */
     if (r+b+g)/3 >= aval then return 1
     return 0
end  /* Do */
return 0                /* shoud never get here */


/***************/
/* process from a cached file 
  return 1 if "used a cache file"; 0 if not. 
  Also, set do_cache=0 if a problem arises */

do_from_cache:procedure expose gif_dir_root verbose do_cache cache_duration is_cgi gfile 
parse arg cache_file
if do_cache=0 then return 0

if do_cache>0 then do
   do_cache=1
   cache_file=gif_dir_root||cache_file
   gfile=cache_file

   eek=sysfiletree(cache_file,afile,'FT')
   if afile.0>0 then do         /* match -- check duration */
        parse var afile.1 dd .
        mkdate=space(translate(left(afile.1,8),' ','/'),0)
        nowdate=space(translate(date('o'),' ','/'),0)
        if abs(nowdate-mkdate) <= cache_duration then do
          if verbose>1 then call gpmprintf(' GIF_TEXT: using cached image file: ' cache_file)
          return 1
       end
       if verbose>1  then call gpmprintf('GIF_TEXT: Rewriting cached image file: ' cache_file)
       return 0
   end  /* Do */
   else do              /* no match -- is there room? */
      foo=sysfiletree(gif_dir_root||'*.*','eek','FO')
      if eek.0 > cache_size then do 
         do_cache=0     /* suppress cache! */
         if verbose>1 then call gpmprintf(' GIF_TEXT: cache_size exceeded, can not cache image file: ' cache_file)
      end  /* Do */
      else do
          if verbose>1 then call gpmprintf(' GIF_TEXT: creating cached image file: ' cache_file)
      end /* do */
   end
end
return 0



/***********************************/
/* get the slide file stuff 
ATYPE has 3 values:
  T= repeat slide
  F= fit (internally repeat)
*/
grab_slide:procedure expose slide. verbose slidect.   is_cgi sqs.
parse upper arg sim,atype,mx,ajy,my,stype,sxc,syc
if sim<>0 then do
  foo=rxgdimagecolorstotal(sim)
  jx=rxgdimagesx(sim)
  jy=rxgdimagesy(sim)
end
else do
   jy=1
   jx=slide.0
end /* do */
jy0=jy
/* which row to read from ? */
if jy>1 & ( stype="F" | stype="T" ) then do  /* multi row style -- use my ajy row */
    select
     when ajy=0 then jy=0
     when ajy=my then jy=jy-1
     when jy>my | stype='F' then do
       tt=ajy/my
       jy=trunc(tt*(jy-1))
     end
     when stype='T' then do
        jy=trunc(ajy//(jy-1))
     end  /* Do */
     otherwise jy=1
   end
end  /* Do */
else do
   if jy>1 then 
       jy=trunc(1+(jy/3))
   else
     jy=0
end

/* if sxc and syc specified, then measrue distance from there (rather then just using
    column #. This means computing max distance from sxc,syc */
if datatype(sxc)='NUM' & datatype(syc)='NUM' then do    /* use distance, not colunm */
    ixc=1+((mx-1)*sxc);   ixc= max(min(ixc,mx),1)
    iyc=1+((my-1)*syc) ;  iyc= max(min(iyc,my),1)
    d1=figdist(ixc,iyc,1,1)
    d2=figdist(ixc,iyc,mx,1)
    d3=figdist(ixc,iyc,mx,my)
    d4=figdist(ixc,iyc,1,my)
    mx=trunc(max(d1,d2,d3,d4))   /* new "max distance from slide */
    if verbose>1 then call gpmprintf(' GIF_TEXT: Max distance from slide_coord='mx)
end

if verbose>1 & ajy//25=1 then 
   call gpmprintf(" GIF_TEXT: Getting color slide from row:" jy ' of ' jy0)

drop aslide.
if sim<>0 then do               /* using slide form file */
  foo=rxgdimagegetrowpixels(sim,jy,aslide)
end
else do                         /* using user set slide */
  do mm=0 to slide.0
     aslide.mm=slide.mm        
  end /* do */
end

/* we now have base slide (from file or from use set); now expand/shrink to fit mx */
slide.0=mx
/* if slide > mx, then pick from slide */
if jx>mx & atype<>'T' then do
   slide.1=aslide.1 
   slide.mx=aslide.jx 
 
   do ll=2 to mx-1
       tt=(ll-1)/(mx-1)
       itt=1+trunc(tt*(jx-1))
       slide.ll=aslide.itt 
   end /* do */
   return 1
end  /* Do */

/* slide < mx, need to expand it */
if atype='T' then do            /* tile it, both cases (jx> or < mx)  */
    ii=0
    do mm=1 to mx
       ii=ii+1
       if ii>jx then ii=1
       slide.mm=aslide.ii 
    end /* do */
    return 1
end  /* Do */

/* fit (internal repeat */
   slide.1=aslide.1 
   slide.mx=aslide.jx 
   do ll=2 to mx-1
       tt=(ll-1)/(mx-1)
       itt=1+trunc(tt*(jx-1))
       slide.ll=aslide.itt 
   end /* do */
   return 1

/***********/
/* squared distance */
figdist:procedure expose sqs. figdist_type
parse arg ax,ay,cx,cy
dx=ax-cx ; dy=ay-cy 

/* which "distance" type to use */

if figdist_type=4 then return max(abs(dx),abs(dy))  /* longest axis */

if figdist_type=2 then  return (abs(dx)+abs(dy))  /* right angle grid steps */

if figdist_type=3 then do               /* modified right angle */
   a1=max(abs(dx),abs(dy))
   a2=min(abs(dx),abs(dy))/2
   return (a1+(a2/2))
end /* do */

/* else, use euclidean */


AAS=( (dx*dx)+(dy*dy))

IF sqs.!got<>0 THEN DO      /* YUCK, USE A NUMERIC SEARCH */
    AAS2=SQRT2(AAS)
end /* do */
ELSE DO
   AAS2=SQRT(AAS)
END
RETURN AAS2

/********************/
/*  a square root finder */
sqrt2:procedure
parse arg aval

if aval<=1 then return aval  

/* do a binary search */

i1=1 ;i11=1;
i3=100 ; i33=10000
do until i33>aval | i3=10000000
  i3=i3*5
  i33=i3*i3
end /* do */
i2=i3/2 ; i22=i2*i2

do forever
if aval=i22 then return i2  /* an exact match */
oldi2=i2
if aval <i22 then do
   i3=i2; i33=i22
   i2=i1+((i3-i1)/2) ; i22=i2*i2
end
else do
   i1=i2 ; i11=i22 ;
   i2=i1+((i3-i1)/2) ; i22=i2*i2
end /* do */
if abs(oldi2-i2)<0.01 then return i2
end


/***********************************/
/* add slide's color table to messim */
add_slide_ct:procedure expose slidect. verbose is_cgi
parse arg mim
ist=rxgdimagegettransparent(mim)
usepre=0
do jj=0 to slidect.0-1
   r=slidect.!r.jj ; g=slidect.!g.jj ; b=slidect.!b.jj
   oo=rxgdimagecolorexact(mim,r,g,b)  /* check if color already exists */
   if oo=-1 | oo=ist then do             /*no exact match, or match transparent  */
      aa=rxgdimagecolorallocate(mim,r,g,b)  /* add this color */
      if aa>-1  then do          /* success */
           slidect.!alt.jj=aa
      end  /* Do */
      else do           /* no more colors, use closest */
         slidect.!alt.jj=rxgdimagecolorclosest(mim,r,g,b)
         usepre=usepre+1
      end
   end  /* Do */
   else do
       slidect.!alt.jj=oo              /* use prexisting color */
   end
end /* do */
if usepre>0 & verbose>1  then call gpmprintf(' GIF_TEXT: too many colors, had to share for 'usepre)

return 1




/***********************************/

/* determine a user scale, given ith of Ilen position, and 
   list of "user_scales". We assume user_scales is a space delimited list
  of numbers, with 1="use current size", >1 means larger, <1 means smaller */

get_user_scale:procedure expose is_cgi
parse arg ith,ilen,user_scales
if user_scales="" then return 1

igoo=words(user_scales)

if ith=1 then return word(user_scales,1)

if ith=ilen then return word(user_scales,igoo)

/* middle characters*/
frac=(ith-1)/(ilen-1)    /* where in scale list is it */
spot=1+ ((igoo-1)*frac)
ifrac=trunc(spot)
afrac=spot-ifrac

if afrac=0 then return word(user_scales,ifrac)

ii=ifrac+1
a1=word(user_scales,ii)
a2=word(user_scales,ifrac)

diff=a1-a2
return (a2+(diff*afrac))


/*****************/
create_ttf_gif:procedure expose red_text green_text blue_text ,
                         red_back green_back blue_back backcolor 

parse arg message,ttfont,psize

rc = rxttf_image(message,ttfont,psize, data)
/* Check for an error */
if rc<>0 then do
    say "Error in rxttf_image: "rc
    exit
end /* do */

/* create the gif */
MCOLS=data.!cols ; MROWS=data.!rows
im=rxgdimagecreate(MCOLS,MROWS)
transparent=0
call rxgdimagecolortransparent im,transparent

oy=rxgdimagecolorallocate(im,red_back,green_back,blue_back)
text_color=rxgdimagecolorallocate(im,red_text,green_text,blue_text)

do ir=0 to data.!rows-1
  aline=translate(data.ir,'01','0001'x)
  do ic=1 to MCOLS
      pxels.ic=substr(aline,ic,1)
  end /* do */
  styled  = RxgdImageSetStyle(im, pxels, data.!cols)         /* write transformed row back to */
  rc = RxgdImageLine(im, 0,ir,MCOLS-1,ir,styled)        /*  the message image */
end /* do */

return im



/***********************************/
/* get the gif name, using several naming tricks */
get_gifname:procedure expose font_ind. is_cgi

parse arg achar,gif_dir,fontname

if length(achar)>1 then achar=translate(achar)
/* check index first */
do iu=1 to font_ind.0
   if font_ind.iu=achar then do 
        cl=gif_dir||font_ind.iu.!file
        if stream(cl,'c','query exists')<>' ' then  return cl
        leave
   end  /* Do */
end /* do */
if length(achar)>1 then return ' '  /* special character not found */


/* is it a valid file name (i.e.; don't look for *.gif*/
if pos(translate(achar),'ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789_$%#&@!~-&^')=0 then RETURN ' '

/* it is lowerr case: look for xlc.gif? */

if translate(achar)<>achar then do
   cl=gif_dir||achar||'lc.gif'
   if stream(cl,'c','query exists')<>' ' then  return cl
   cl=gif_dir||fontname||achar||'lc.gif'
   if stream(cl,'c','query exists')<>' ' then  return cl
   cl=gif_dir||fontname||'-'||achar||'lc.gif'
   if stream(cl,'c','query exists')<>' ' then  return cl

end  /* Do */

/* try generic name: look for x.gif? */
cl=gif_dir||achar||'.gif'
if stream(cl,'c','query exists')<>' ' then  return cl
cl=gif_dir||fontname||achar||'.gif'
if stream(cl,'c','query exists')<>' ' then  return cl
cl=gif_dir||fontname||'-'||achar||'.gif'
if stream(cl,'c','query exists')<>' ' then  return cl
cl=gif_dir||achar||fontname||'.gif'
if stream(cl,'c','query exists')<>' ' then  return cl

return ' '



/******/
/* check for valid 0-255 value, set to def if not */
check_byte:procedure
parse arg aval,adef
if adef=' ' then adef=0
if datatype(aval)<>'NUM' then return adef
if aval<0 | aval>255  then return adef
return aval



/*******/
/* read a font index file into font_ind. */
read_font_index:procedure expose font_ind.  gif_dir  def_transparent def_textcolor def_backcolor is_cgi
parse arg afile

defgifs=' '; xoffset=0 ; yoffset=0 ; inrow=16 ; hchar=47  ; wchar=35 ;isbw=1
charset=' !"'||"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcdefghijklmnopqrstuvwxyz{|}~"
leftoffset=0;rightoffset=0;topoffset=0;bottomoffset=0
transparent="" ; manytype=1
x_user_scales='' ; y_user_scales="" ;y_valign=' ' ;slide='' ;  slide_horiz=''
slide_thresh='P1' ; slide_vert=''
slide_size=""  ; textcolor="" ; backcolor="" ; slide_prob=''

font_ind.0=0
font_ind.!defgifs=defgifs
font_ind.!xoffset=xoffset
font_ind.!yoffset=yoffset
font_ind.!topoffset=topoffset
font_ind.!bottomoffset=bottomoffset
font_ind.!rightoffset=rightoffset
font_ind.!leftoffset=leftoffset
font_ind.!inrow=inrow
font_ind.!hchar=hchar
font_ind.!wchar=wchar
font_ind.!isbw=isbw
font_ind.!charset=charset
font_ind.!manytype=1
font_ind.!x_user_scales=''
font_ind.!y_user_scales=''
font_ind.!y_valign=''
font_ind.!slide=''
font_ind.!slide_horiz=''
font_ind.!slide_vert=''
font_ind.!slide_thresh=''
font_ind.!transparent=def_transparent
font_ind.!textcolor=def_textcolor
font_ind.!backcolor=def_backcolor
font_ind.!slide_size=0
font_ind.!slide_coord=''
font_ind.!slide_blue=''
font_ind.!slide_red=''
font_ind.!slide_green=''
font_ind.!slide_prob=""

if afile=' ' then return 0
ii=0
if stream(afile,'c','query exists')=' ' then return 0
do until lines(afile)=0
  ii=ii+1
  tmp.ii=linein(afile)
end
tmp.0=ii
foo=stream(afile,'c','close')

iin=0
do mm=1 to tmp.0
   aline=strip(tmp.mm)
   if aline=' ' then iterate
   if abbrev(aline,'**')=1 then iterate  /* comment */
   athing=' '
   if pos('=',aline)<>0 then do
       parse var aline athing '=' stuff ; athing=strip(translate(athing))
   end  /* Do */
   select
     when abbrev(athing,'DEFAUL')+ABBREV(ATHING,'COMPLET')>0 then  defgifs=defgifs||' '||strip(stuff)
     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
     when abbrev(athing,'DEF_CHAR_OF')+abbrev(athing,'DEFCHAROF')>0 then do
             stuff=translate(stuff,' ',',')            
             parse var stuff a1 a2 a3 a4                    
             if datatype(a1)='NUM'  then leftoffset=a1    
             if datatype(a2)='NUM'  then topoffset=a2    
             if datatype(a3)='NUM'  then rightoffset=a3    
             if datatype(a4)='NUM'  then bottomoffset=a4    
     end  /* Do */
     when abbrev(athing,'DEF_TR')+abbrev(athing,'TRAN')>0 then do
           if datatype(stuff)='NUM'  then transparent=stuff
     end

     when abbrev(athing,'DEF_TEXTC')+abbrev(athing,'TEXT')>0 then do
        if verify(stuff,'0123456789ABCDEFabcdef#')=0 then  textcolor=stuff
     end

     when abbrev(athing,'DEF_BACKC')+abbrev(athing,'BACK')>0 then do
        if verify(stuff,'0123456789ABCDEFabcdef#')=0 then  backcolor=stuff
     end

     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 abbrev(athing,"MANY_D")+abbrev(athing,'MANYD')+ ,
          abbrev(athing,"MANY_C")+abbrev(athing,'MANYC')>0 then do
       manytype=wordpos(translate(stuff),'CYCLE FIT END RANDOM ')
       if manytype=0 then manytype=1
     end
     when athing='DEF_INROW' then
              if datatype(strip(stuff))='NUM' then inrow=strip(stuff)
     when athing='CHAR' then do
      parse var stuff aval afile
      if datatype(aval)<>'NUM' then iterate /* error- ignoe */
      if aval<0  | aval>99 then iterate /* out of range, ignore */
      aval=strip(aval,'l','0')
      font_ind.!chars.aval=strip(afile)
      iterate
     end
     when abbrev(athing,"X_SC")+abbrev(athing,'XSC')>0 then
        x_user_scales=stuff
     when abbrev(athing,"Y_SC")+abbrev(athing,'YSC')>0 then
        y_user_scales=stuff
     when abbrev(athing,'VAL')+abbrev(athing,'Y_VAL')>0 then
        y_valign=stuff
     when abbrev(athing,'SLIDE_H')>0 then
        slide_horiz=packur2(stuff)
     when abbrev(athing,'SLIDE_V')>0 then
        slide_vert=packur2(stuff)
     when abbrev(athing,'SLIDE_T')>0 then
        slide_thresh=packur2(stuff)
     when abbrev(athing,'SLIDE_F')>0 | athing='SLIDE' then do
        slide=packur2(stuff)
        if pos(':',slide)+pos('\',slide)=0 then
           slide=gif_dir||slide
     end
     when abbrev(athing,'SLIDE_R')>0 then
        slide_red=packur2(stuff)
     when abbrev(athing,'SLIDE_G')>0 then
        slide_green=packur2(stuff)
     when abbrev(athing,'SLIDE_B')>0 then
        slide_blue=packur2(stuff)
     when abbrev(athing,'SLIDE_C')>0 then
        slide_coord=packur2(stuff)
     when abbrev(athing,'SLIDE_P')>0 then
        slide_prob=packur2(stuff)
     when abbrev(athing,'SLIDE_S')>0 then do
         tt=packur2(stuff)
         if datatype(tt)='NUM' then slide_size=tt
     end  /* Do */
     when abbrev(aline,'##')>0 then do  /* it's an ascii value to file map */
        parse var aline '##' iichar afile
        iichar=strip(iichar)
        if right(iichar,1)='x' | right(iichar,1)='h' then do
            iichar=left(iichar,length(iichar)-1)
            iichar=x2d(iichar)
        end /* do */
        if datatype(iichar)='NUM' then do
           iin=iin+1
           font_ind.iin=d2c(iichar)   ; font_ind.iin.!file=strip(afile)
        end
     end /* do */
     otherwise do               /* it's a charater to file map */
        parse var tmp.mm achar afile
        if length(achar)>1 then achar=translate(achar)
        iin=iin+1
        font_ind.iin=strip(achar)   ; font_ind.iin.!file=strip(afile)
     end
   end
end /* do */



if isbw>0 then isbw=1
font_ind.!defgifs=defgifs
font_ind.!xoffset=xoffset
font_ind.!yoffset=yoffset

font_ind.!topoffset=topoffset
font_ind.!bottomoffset=bottomoffset
font_ind.!rightoffset=rightoffset
font_ind.!leftoffset=leftoffset

font_ind.!inrow=inrow
font_ind.!hchar=hchar
font_ind.!wchar=wchar
font_ind.!isbw=isbw
font_ind.!charset=charset
font_ind.!transparent=transparent 
font_ind.!manytype=manytype
font_ind.!x_user_scale=x_user_scales
font_ind.!y_user_scale=y_user_scales
font_ind.!y_valign=y_valign
font_ind.!slide=slide
font_ind.!slide_horiz=slide_horiz
font_ind.!slide_thresh=slide_thresh
font_ind.!slide_vert=slide_vert
font_ind.!textcolor=textcolor
font_ind.!backcolor=backcolor

font_ind.!slide_size=slide_size
font_ind.!slide_red=slide_red
font_ind.!slide_green=slide_green
font_ind.!slide_blue=slide_blue
font_ind.!slide_coord=slide_coord
font_ind.!slide_prob=slide_prob

font_ind.0=iin

return iin

/**********/
/* fIX A user scale entry */
fix_scale:procedure
parse arg ascale
if ascale=0 then return 1
ascale=translate(ascale,' ','+')
tt=''
do mm=1 to words(ascale)
   av=strip(word(ascale,mm))
   if datatype(av)<>'NUM' then  iterate
   tt=tt' 'av
end  /* Do */

return tt



/**************************/
/* 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


/********************/
/* return time, using REXX time_fmt. Also, special code: 1 - C without am or pm */
get_time:procedure
parse arg tfmt

if pos(tfmt,'CHLMNS1')=0 then tfmt='N'
if tfmt='1' then do
  aa=time('C')
  a2=translate(right(aa,2))
  oof=2
  if a2="AM" then oof=1         /* reserved special character: 1=am, 2=pm */
  return left(aa,length(aa)-2)||d2c(oof)
end
return time(tfmt)

/********************/
/* return time, using REXX time_fmt */
get_date:procedure
parse arg tfmt

if pos(tfmt,'BDELMNOSUW')=0 then tfmt='N'

return date(tfmt)


/************************************************/
/* procedure from TEST-CGI.CMD by  Frankie Fan <kfan@netcom.com>  7/11/94 */
DecodeKeyVal: procedure
  parse arg Code
  Text=''
  Code=translate(Code, ' ', '+')
  rest='%'
  do while (rest\='')
     Parse var Code T '%' rest
     Text=Text || T
     if (rest\='' ) then
      do
        ch = left( rest,2)
        if verify(ch,'01234567890ABCDEF')=0 then
           c=X2C(ch)
        else
           c=ch
        Text=Text || c
        Code=substr( rest, 3)
      end
  end
  return Text

/*********/
packur2:procedure expose is_cgi
parse arg a1b0

if is_cgi=0 then
   return packur(translate(a1b0,' ','+'))
else
   return decodekeyval(translate(a1b0,' ','+'))

/************/
wow1:
call gpmprintf(" GIF_TEXT error at line "sigl' 'rc)
      if is_cgi=0 then do
         'NODATA'
         exit '400 0'
      end
      else do
           exit 
      end /* do */


/***********************/
/* see if an alphabyte specific default is available */
get_default_char:procedure expose font_ind. verbose dim. red_back green_back blue_back ,
                        red_text green_text blue_text is_cgi
parse arg achar,ithchar,mlen,manymax

if font_ind.!ndims=0 then return 1
ikk=1
nfonts=font_ind.!ndims
if manymax>0 & manymax<nfonts then nfonts=manymax
if nfonts>1 then do
  select
     when font_ind.!manytype=1 then do  /* cycle */
       ikk=ithchar//nfonts
       if ikk=0 then ikk=nfonts
     end
     when font_ind.!manytype=3 then do   /* end */
        ikk=min(nfonts,ithchar)
     end  /* Do */
     when font_ind.!manytype=4 then do  /* random */
        ikk=random(1,nfonts)
     end
     otherwise    do      /* fit */
        ikk=1+trunc(nfonts*ithchar/(mlen+0.1))
     end
  end
end
ic=pos(achar,font_ind.!charset)
if ic=0 then do
  achar=translate(achar)
  ic=pos(achar,font_ind.!charset)
end
if ic=0 then return 1

/* for each character in the charset ... */
/* determine x offset: */
   irow=1+((ic-0.1)%font_ind.!inrow)
   icol=ic-((irow-1)*font_ind.!inrow)

/* upper left is 0,0 */
   xat=font_ind.!xoffset + ((icol-1)*font_ind.!wchar)+font_ind.!leftoffset
   yat=font_ind.!yoffset+ ((irow-1)*font_ind.!hchar)+font_ind.!topoffset
   jx=font_ind.!wchar-(font_ind.!leftoffset+font_ind.!rightoffset)
   jy=font_ind.!hchar-(font_ind.!bottomoffset+font_ind.!topoffset)
   cim=rxgdimagecreate(jx,jy)
   if font_ind.!isbw=0 then do  /* use colors as is, but include back text colors */
      oy1=rxgdimagecolorallocate(cim,red_back,green_back,blue_back)
      oy2=rxgdimagecolorallocate(cim,red_text,green_text,blue_text)
   end

   tdim=dim.ikk         /* use the ikk (of possible many_complete) complete font */
   foo=rxgdimagecopy(cim,tdim,0,0,xat,yat,jx,jy)
   if font_ind.!isbw=1 then do   /* convert b/w to back/text colors */
       ww=rxgdimagegettransparent(cim)
      foo=rxgdimagecolordeallocate(cim,0)
      oy1=rxgdimagecolorallocate(cim,red_back,green_back,blue_back)
      foo=rxgdimagecolordeallocate(cim,1)
      oy2=rxgdimagecolorallocate(cim,red_text,green_text,blue_text)
   end

   return cim


/*********************************/
/* return r g b of aim at ctable ival */
three_color:procedure
parse arg aim,ctable
r=rxgdimagered(aim,ctable)
g=rxgdimagegreen(aim,ctable)
b=rxgdimageblue(aim,ctable)
return r g b

/*********************************/
/* stand alone mode -- build the "list " */
ask_values:procedure expose gfile2 gif_dir_root cy_ye normal bold re_wh reverse 

SIGNAL OFF  ERROR ; SIGNAL OFF SYNTAX
SIGNAL ON ERROR NAME ASKV 
 SIGNAL ON SYNTAX NAME ASKV 

ansion=checkansi()
if ansion=1 then do
  aesc='1B'x
  cy_ye=aesc||'[37;46;m'
  normal=aesc||'[0;m'
  bold=aesc||'[1;m'
  re_wh=aesc||'[31;47;m'
  reverse=aesc||'[7;m'
end
else do
  say " Warning: Could not detect ANSI....  output will look ugly ! "
  cy_ye="" ; normal="" ; bold="" ;re_wh="" ;
  reverse=""
end  /* Do */

cls
say  " " ; say

call lineout, bold cy_ye
call lineout, " GIF_TEXT (ver 1.3a): a text-to-gif utility -- command line mode "
call lineout, normal


say " Although designed primarily as a WWW script, you can use GIF_TEXT "
say " to create .GIF files in a stand-alone mode."
say
say "      "||cy_ye||"GIF_TEXT does not have graphics display capability    " normal
say "      "||cy_ye||" ... but you can invoke your browser (or other graphics " normal
say "      "||cy_ye||"     graphics) to view .GIF files generated by GIF_text.." normal
say "  "

if yesno(" Are you ready to continue ")=1 then
 nop
else do
 say " See you later?.. "
 exit
end

/* try reading in prior answers file */
priora=""
if stream('GIF_TEXT.ANS','c','query exists')<>"" then do
say 
   say bold ' ... reading prior options from GIF_TEXT.ANS'  normal
   priora=charin('GIF_TEXT.ANS',1,chars('GIF_TEXT.ANS'))
   foo=stream('GIF_TEXT.ANS','c','close')
end /* do */
def.!font="?"; def.!backgrnd="?";def.!colorslide='?'
def.!width=0 ; def.!height=0
def.!moreopts='?'
def.!message='hello'
def.!outgfile='foo.gif'
asep='|^&^|'

do until priora=""
   parse var priora a1 '|^&^|' priora
   parse var a1 a1a '=' a1b
   a2='!'||strip(translate(a1a))
   def.a2=a1b
end /* do */

say

if stream('GIF_TEXT.DOC','c','query exists')<>'' then do
     ii=yesno(normal"      "bold"Would you like to view GIF_TEXT.DOC ?"normal,,'N')
     if ii=1 then
          '@START  "The GIF_text Manual" /C /F /WIN E GIF_TEXT.DOC'
    ELSE
        say" On the other hand, you can always learn by making misteaks .... "
end
ELSE DO
   say " We recommend reading the documentation (GIF_TEXT.DOC) before "
   say " running this program. "
 end /* do */

say
whatfont:
call charout , "What "reverse "alphabyte font "normal" do you want to use (?=list,ENTER="def.!font"):"
pull font
if font=""  then font=def.!font

if font="?" then do
   say 
    say reverse ' List of alphabytes & fonts ' normal
    do while queued()>0
        pull .
    end /* do */
    oog=sysfiletree(gif_dir_root'*.*',qlist,'DO')
    foo=show_dir_queue(1)
    signal whatfont
end  /* Do */
if pos('\',whatfont)+pos(':',font)<>1  then do
     yoob=gif_dir_root||font
     wow=sysfiletree(yoob'\*.*',geeks)
     if geeks.0=0  then do
             say bold " ** Could not find directory for: " normal font
             signal whatfont
     end /* do */
end /* do */


say
getbACK:
call charout , bold"Background file (0=None, ?=list, Enter="def.!backgrnd"):" normal
pull backgrnd
if backgrnd='' then backgrnd=def.!backgrnd
if backgrnd="?" then do
    say 
    say reverse ' List of background files in: ' normal bold gif_dir_root'BACKS' normal
    do while queued()>0
        pull .
    end /* do */
    '@DIR /b  '||gif_dir_root||'BACKS\*.gif | rxqueue'
    foo=show_dir_queue('.GIF')
    signal getback
end
if pos('\',backgrnd)+pos(':',backgrnd)=0  & backgrnd<>0 then do
  backgrnd='BACKS\'||backgrnd
  if stream(gif_dir_root||backgrnd||'.gif','c','query exists')='' then do
      say " Could not find background file: " backgrnd
      signal getback
  end /* do */
end

say
getslide:
colorslide=0
call charout , bold"Color slide (0=None, ?=list, ENTER="def.!colorslide"):" normal
pull colorslide
if colorslide=''  then colorslide=def.!colorslide
if colorslide="?" then do
    say 
    say reverse ' List of color slides files in: ' normal bold gif_dir_root'SLIDES' normal
    do while queued()>0
        pull .
    end /* do */
    '@DIR /b  '||gif_dir_root||'SLIDES\*.gif | rxqueue'
    foo=show_dir_queue('.GIF')
    signal getslide
end
if pos('\',colorslide)+pos(':',colorslide)=0  & colorslide<>0 then do
  colorslide='slides\'||colorslide
  if stream(gif_dir_root||colorslide||'.gif','c','query exists')='' then do
      say " Could not find color slide file: " colorslide
      signal getslide
  end /* do */
end


say
getht:
call charout , bold"Height (in pixels), 0=automatic, ENTER="def.!height": "normal
pull height
if height="" then height=def.!height
if datatype(height)<>'NUM' then signal getht

getwt:
call charout , bold "Width (in pixels), 0=automatic ENTER="def.!width": "normal
pull width
if width="" then width=def.!width
if datatype(width)<>'NUM' then signal getwt


amess:
Say
Say bold "Enter your message " normal" ($d=date, $t=time, $n=newline, $f(fontname)=font switch "
say bold "   (ENTER=" normal reverse Def.!message normal bold ")" normal
call charout ,bold "The message:"normal
parse pull adesc
if adesc='' then adesc=def.!Message
adesc=a_replacestrg(adesc,'&','%26;','ALL')
message=translate(adesc,'+',' ')

get_opts:
say
say "Additional options (0=none,? for help, * xx = add xx to prior options "
say" ENTER=prior options=" bold def.!moreopts  normal
call charout, bold " ? " normal
pull moreopts
if moreopts='' then moreopts=def.!Moreopts

moreopts=a_replacestrg(moreopts,'*',def.!Moreopts,'ALL')
if strip(moreopts)=0 then moreopts=''
if moreopts<>'?' then say " Using options: " moreopts

if moreopts='?' then do
 call show_other_opts
 signal get_opts
end
moreopts=translate(moreopts,'&',' ')

/* now make a list */

list="font="||font||'&text='||message||'&height='||height||'&width='||width
list=list||'&back='||backgrnd||'&slide='||colorslide
if moreopts<>'' then list=list||'&'||moreopts

getgfile2:
Say
call charout,bold"Enter output file name (ENTER="def.!outgfile"):"normal
pull gfile2
if gfile2="" then gfile2=def.!outgfile
if gfile2="" then signal getgfile2
gfile0=stream(gfile2,'c','query exists')
if gfile0<>"" then do
    call charout,Gfile0 ' exists. Overwrite (Y/N)'
    pull anans
    if abbrev(strip(anans),'Y')<>1 then signal getgfile2
end /* do */
outgfile=gfile2

say
say " saving answers to GIF_TEXT.ANS "



aa='WIDTH='width||asep||'HEIGHT='height||asep||'FONT='font||asep
aa=aa||'BACKGRND='backgrnd||asep||'COLORSLIDE='colorslide||asep
aa=aa||'OUTGFILE='outgfile||asep||'MOREOPTS='Moreopts||asep
aa=aa||'MESSAGE='message||asep
foo=charout('GIF_TEXT.ANS',aa,1)
foo=stream('GIF_TEXT.ANS','c','close')

say " creating the image ..... "
return list  /* gfile2 is exposed */


ASKV:
SAY "Sorry, you made a goof.  Try again " sigl
exit


/*********/
show_other_opts:
say 
say '                      'cy_ye 'More commonly used options. 'normal 
say bold' TIME_FMT,DATE_FMT'normal':Time&date format. timefmt=p (LNHSCM1), datefmt=p (NDEMBOSUW)' 
say bold' BACK_SCALE:'normal' background display. back_scale=0/1 ; 1=scale, 0=tile '
say bold' X_F, Y_F:'normal' Frame size (left & right, top  & bottom), in pixels. x_f=n y_f=n'
say bold' X_OF, Y_OF:'normal' Extra X, and Y, offset (to right,to bottom). x_of=n y_of=n '
say bold' X_SCA,Y_SCA:'normal'Width&height scales: X_SCA=v+v  Y_SCA=v+v..(v<1:shrink, >1:enlarge'
say bold'      Y_VAL:'normal' Type of vertical alignment: Y_VAL=p ; p=TMB '
say bold'     LINE_J:'normal' Horizontal justifications (multi-line messages only)'
say ' These SLIDE_x options are only used when a color slide is specified'
say bold'    SLIDE_T:'normal' Threshold rules & parameter for color slides: slide_t=pnnn, p=PBC'
say bold'    SLIDE_V:'normal' Vertical mapping rule for color slides : T(ile),F(it),N(one)'
say bold'    SLIDE_H:'normal' Horizontal mapping rule for color slides (T(ile),F(it)'
say bold'    SLIDE_C:'normal' Center coordinates for color slide: slide_c=v+v'
say bold'   SLIDE_SI:'normal' Size of "user specified color slide" (# colors): slide_si=n'
say bold'   SLIDE_RE:'normal' Red color parameters for created slide: slide_red=v+v+.."'
say bold'   SLIDE_GR:'normal' Green color parameters for created slide: slide_gr=v+v+.. "'
say bold'   SLIDE_BL:'normal' Blue color parameters for created slide: slide_bl=v+v+..'
say bold'   SLIDE_PR:'normal' Probability parameters for using slide value: slide_pr=v+v+..'
say  reverse'Example:'normal ' time_fmt=N  Y_SCA=0.5+1.2+2 x_F=2 y_f=2'
say  reverse'Notes:'normal" p=parameter, n=0..9, nnn=0..255, v=0.0...1.0; v+v+.. = list of v's "              

return 1


/*********/
/* show stuff in queue as a list */
show_dir_queue:procedure expose qlist.
parse arg lookfor
    ibs=0 ;mxlen=0
    if lookfor<>1 then
       nq=queued()
     else
        nq=qlist.0
    do ii=1 to nq
       if lookfor=1 then do
          aa=qlist.ii
          ii2=lastpos('\',aa) ; anam=substr(aa,ii2+1)
       end /* do */
       else do
          pull aa
          if pos(lookfor,aa)=0 then iterate
          parse var aa anam (lookfor) .
          if strip(anam)='.' | strip(anam)='..' then iterate
       end
       ibs=ibs+1
       blist.ibs=anam
       mxlen=max(length(anam),mxlen)
    end /* do */
arf=""
do il=1 to ibs
   anam=blist.il
   arf=arf||left(anam,mxlen+2)
   if length(arf)+mxlen+2>75  then do
        say arf
        arf=""
   end /* do */
end /* do */
if length(arf)>1 then say arf
say
return 1






 /* ------------------------------------------------------------------ */
 /* function: Check if ANSI is activated                               */
 /*                                                                    */
 /* call:     CheckAnsi                                                */
 /*                                                                    */
 /* where:    -                                                        */
 /*                                                                    */
 /* returns:  1 - ANSI support detected                                */
 /*           0 - no ANSI support available                            */
 /*          -1 - error detecting ansi                                 */
 /*                                                                    */
 /* note:     Tested with the German and the US version of OS/2 3.0    */
 /*                                                                    */
 /*                                                                    */
 CheckAnsi: PROCEDURE
   thisRC = -1

   trace off
                         /* install a local error handler              */
   SIGNAL ON ERROR Name InitAnsiEnd

   "@ANSI 2>NUL | rxqueue 2>NUL"

   thisRC = 0

   do while queued() <> 0
     queueLine = lineIN( "QUEUE:" )
     if pos( " on.", queueLine ) <> 0 | ,                       /* USA */
        pos( " (ON).", queueLine ) <> 0 then                    /* GER */
       thisRC = 1
   end /* do while queued() <> 0 */

 InitAnsiEnd:
 signal off error
 RETURN thisRC






a_replacestrg:

exactmatch=0
backward=0 ; doall=0

parse arg astring ,  target   , putme , type , exactmatch

type = translate(type)
if type="BACKWARD" then backward="YES"
if type="ALL" then doall="YES"

iat=1
joelen=length(target)
joelen2=length(putme)

doagain:                /* here if doall=yes */
 if exactmatch="YES" then do
    if   backward="YES" then
        joe= lastpos(target,astring)
    else
        joe= pos(target,astring,iat)
 end
 else do
   if   backward="YES" then
        joe= lastpos(translate(target),translate(astring))
    else
        joe= pos(translate(target),translate(astring),iat)
 end
 if joe=0 then
         return astring

 astring=delstr(astring,joe,joelen)
 if putme<>' ' then
    astring=insert(putme,astring,joe-1)

 if doall="YES" then do
     iat=joe+joelen2
     signal doagain
 end
/* else, all done */
 return astring




/* -------------------- */
/* get a yes or no , return 1 if yes */
yesno:procedure expose normal reverse bold
parse arg fooa , allopt,altans
if altans<>" " & words(altans)>1 then do
   w1=strip(word(altans,1))
   w2=strip(word(altans,2))
   a1=left(w1,1) ; a2=left(w2,1)
   a1a=substr(w1,2) ; a2a=substr(w2,2)
end
else do
    a1='Y' ; a1a='es'
    a2='N' ; a2a='o'
end  /* Do */
ayn='  '||bold||a1||normal||a1a||'\'||bold||a2||normal||a2a
if allopt=1 then  ayn=ayn||'\'||bold||'A'||normal||'ll'

do forever
 foo1=normal||reverse||fooa||normal||ayn
 call charout,  foo1 normal ':'
 pull anans
 if abbrev(anans,a1)=1 then return 1
 if abbrev(anans,a2)=1 then return 0
 if allopt=1 & abbrev(anans,'A')=1 then return 2
end

nocon:
if rc=-7 then return 0
exit 0

gpmprintf:procedure expose is_cgi
parse arg a1

if is_cgi=2 then do
  say a1
  return 1
end

if rxfuncquery('pmprintf')=0 then
    call pmprintf(a1)
return 0


