MODULE 'dos/rdargs', 'dos/dostags', 'utility/tagitem', 'dos/dos',
       'other/stderr','other/stayrandom'

ENUM OK,MEM,OPEN,READ,ARGS,CTRLC,ARG_ERR=0,ARG_IN,ARG_OUT,ARG_SIM,
     ARG_MOO,ARG_MAX

RAISE MEM   IF List()=NIL,
      MEM   IF String()=NIL,
      OPEN  IF Open()=NIL,
      ARGS  IF ReadArgs()=NIL,
      "^C"  IF CtrlC()=TRUE

PROC randasc(easy)
DEF test=0
 SELECT easy
  CASE 0
   RETURN "A" + Rnd(26)
  CASE 1
   RETURN IF Rnd(100)>50 THEN "A" + Rnd(26) ELSE "a" + Rnd(26)
  CASE 2
   test:=Rnd(100)
   IF test < 33 THEN RETURN "A" + Rnd(26)
   IF test < 66 THEN RETURN "a" + Rnd(26)
   RETURN "0" + Rnd(10)
  CASE 4
   test:=Rnd(100)
   IF test < 50 THEN RETURN "!" + Rnd(94)
   test:=Rnd(94) + 161
   IF test>172 THEN INC test
   RETURN test
  DEFAULT
   RETURN "!" + Rnd(92)
 ENDSELECT
ENDPROC


PROC main() HANDLE

 DEF in=0,out=0,gramwidth=0,xdepth=0,col,pattern,arg_format,
     patternbeg,patternend,buf,template,xtrahelp,myarg:PTR TO rdargs,
     patterncur,indata,pat,n,p=0,del,mv,ins,rdarg:PTR TO rdargs,
     args[ARG_MAX]:LIST,easy=3,tmp
 myarg := pattern := indata := rdarg := 0
 err_Name('mk3d')
 template := 'ERR=ERRORS/K,IN=INPUT/A,OUT=OUTPUT,S=SIMPLE/N,MOO/S'
 xtrahelp := 'Usage: mk3d IN "filename" [OUT "filename"] [ERR "filename"]\n' +
 '            [S "number"]\n\n' +
 ' IN specifies a mandatory input file to read for a template.\n' +
 'OUT specifies an optional output file to write.\n' +
 'ERR specifies an optional error file to write (instead of stderr).\n' +
 '  S specifies how simple the characters should be, by this chart:\n\n' +
 '      0 = Only uppercase characters\n' +
 '      1 = Upper/lowercase characters\n' +
 '      2 = AlphaNumeric characters\n' +
 '      3 = AlphaNumeric characters with symbols (default)\n' +
 '      4 = Anything printable via Topaz font\n\n' +
 'For information about the IN file''s format, please, read mk3d.doc.\n' +
 'NOTE: This program based on the same written for MS-DOS.\n' +
 '      Modified somewhat heavily by Joseph E. Van Riper III\n' +
 '      of the Cheese Olfactory Workshop.\n\n' 
  
 buf:=String(80)

/* Handle the arguments (somehow)
 */
 args[ARG_IN]:=0
 args[ARG_OUT]:=0
 args[ARG_ERR]:=0
 args[ARG_SIM]:=0
 args[ARG_MOO]:=FALSE
 myarg:=AllocDosObject(DOS_RDARGS, TAG_DONE)
 myarg.exthelp := xtrahelp
 arg_format:=template
 rdarg:=ReadArgs(arg_format,args,myarg)

 FOR del:=0 TO ARG_MAX-1
  CtrlC()
  SELECT del
   CASE ARG_IN
    IF args[ARG_IN]<>0
     in := Open(args[ARG_IN], MODE_OLDFILE)
     SetIoErr(0)
     err_WriteF('IN: \s\n',[args[ARG_IN]])
    ELSE
     Raise(ARGS)
    ENDIF
   CASE ARG_OUT
    IF StrLen(args[ARG_OUT]) AND (args[ARG_OUT]<>0)
     out := Open(args[ARG_OUT], MODE_NEWFILE)
     SetIoErr(0)
     err_WriteF('OUT: \s\n',[args[ARG_OUT]])
    ELSE
     out := stdout
    ENDIF
   CASE ARG_ERR
    IF StrLen(args[ARG_ERR]) AND (args[ARG_ERR]<>0)
     err_New(args[ARG_ERR])
    ENDIF
   CASE ARG_SIM
    tmp:=args[ARG_SIM]
    IF tmp
     easy := ^tmp
    ELSE
     easy := 3
    ENDIF
   CASE ARG_MOO
    IF args[ARG_MOO]
     WriteF('\nCongrads.. you''re very observant!\n' +
            'Unfortunately, all you get is a nice little:\n' +
            'Mooooooooo.\n')
     ENDIF
   DEFAULT
    Raise('$VER: mk3d 1.1 (3.3.95)')
  ENDSELECT
 ENDFOR
/* READ IN GRAMWIDTH: STEREOGRAM WIDTH (INCLUDE 2*XDEPTH + FEW MORE)
 */

 IF ReadStr(in, buf) = TRUE THEN Raise(READ)
 gramwidth := Val(buf,NIL)
 SetIoErr(0)
 err_WriteF('Gramwidth: \d\n',[gramwidth])
 IF ( (gramwidth < 1) OR (gramwidth > 512) )
  Raise("GRAM")
 ENDIF

 /* READ IN XDEPTH: LENGTH OF REPEATING BG PATTERN
  */
 IF ReadStr(in, buf) = TRUE THEN Raise(READ)
 xdepth := Val(buf,NIL)
 SetIoErr(0)
 err_WriteF('Xdepth: \d\n',[xdepth])
 IF ( (xdepth < 5) OR (xdepth > 64) OR ((xdepth*2) > gramwidth) )
  Raise("XDEP")
 ENDIF

 /* PRINT FUSION X'S
  */
 FOR col:=1 TO gramwidth-1
  CtrlC()
  FputC( out, IF Mod(col,xdepth) THEN " " ELSE "X" )
 ENDFOR
 FputC( out, 10 )
 

 /* SEED RANDOM NUMBER GENERATOR (if desired)
  */

 stayrandom()

 pattern := List(xdepth+1)
 indata := String(gramwidth+1)

 /* IF NOT EOF, GET A LINE OF DATA
  */
 WHILE (ReadStr(in,indata)<>-1)
  /* GENERATE A NEW RANDOM PATTERN,
   * OUTPUT FULL PATTERN TO START THE LINE
   */
  CtrlC()
  FOR pat:=0 TO xdepth
   CtrlC()
   pattern[pat] := randasc(easy)
   IF pat <> xdepth THEN FputC ( out, pattern[pat] )
  ENDFOR

  /* N IS VALUE OF NEXT CHAR, P IS VALUE OF PREVIOUS CHAR
   */

  patterncur := patternbeg := col := p := n := 0
  patternend := xdepth

  /* WHILE NOT EOL
   */
  WHILE (col < (gramwidth-xdepth))
   /* SET N TO VALUE OF NEXT CHAR
    */
   CtrlC()
   IF ( (indata[col] >= "1") AND (indata[col] <= "9") )
    n := indata[col] - "0"
    SetIoErr(0)
    err_WriteF('\d',[n])
   ELSE
    n := 0
    SetIoErr(0)
    err_WriteF(' ')
   ENDIF

   /* IF NEXT VALUE IS NOT THE SAME AS THE PREV VALUE (LEVEL SHIFT)
    */
   IF (n <> p)
    /* IF SHIFTING 'UP' (CLOSER TO USER)
     */
    IF (n > p)
     /* DEL NEXT N-P BITS IN PATTERN
      */
     FOR del := 0 TO (n-p-1)
      CtrlC()
      mv := patterncur
      REPEAT
       CtrlC()
       pattern[mv]:=pattern[mv+1]
       INC mv
      UNTIL (mv=(patternend+1))
      DEC patternend
      IF (patterncur = patternend) THEN patterncur := patternbeg
     ENDFOR
    /* SHIFTING 'DOWN' (AWAY FROM USER)
     */
    ELSE
     /* INSERT P-N RANDOM BITS INTO PATTERN
      */
     FOR ins := 0 TO (p-n-1)
      CtrlC()
      FOR mv:=patternend+2 TO patterncur+1 STEP -1
       CtrlC()
       pattern[mv]:=pattern[mv-1]
      ENDFOR
      pattern[patterncur]:=randasc(easy)
      INC patternend
     ENDFOR
    ENDIF

    /* UPDATE P
     */
    p := n

    /* OUTPUT NEXT CHAR IN RANDOM PATTERN
     */
    FputC(out,pattern[patterncur])
    
   /* NEXT VALUE IS SAME AS PREVIOUS VALUE
    */
   ELSE
    /* OUTPUT NEXT CHAR IN RANDOM PATTERN
     */
    FputC(out,pattern[patterncur])
    
   ENDIF
  /* ADVANCE PATTERN PTR
   */
   INC patterncur
   IF (patterncur = patternend) THEN patterncur := patternbeg

  /* ADVANCE INPUT PTR
   */
   INC col
  ENDWHILE
  /* END OF LINE: OUTPUT NEWLINE CHAR, CLEAN LINE BUFFER
   */
  Fputs(out,'\n')
  SetIoErr(0)
  err_WriteF('\n')
  FOR del:=0 TO gramwidth+1
   indata[del]:=0
  ENDFOR
 ENDWHILE

 /* END OF FILE: DONE, CLOSE UP
  */
 Raise(0)

EXCEPT

 IF in THEN Close(in)
 IF out AND (out<>stdout) THEN Close(out)
 IF pattern THEN Dispose(pattern)
 IF indata THEN Dispose(indata)
 IF rdarg THEN FreeArgs(rdarg)
 IF myarg THEN FreeDosObject(DOS_RDARGS,myarg)
 
 p := 'something (maybe internal error).\n'

 SELECT exception
 
  CASE OK
   p := 0
  CASE OPEN
   IF (in=NIL)
    err_WriteF('Cannot open infile.\n')
   ELSEIF (out=NIL)
    err_WriteF('Cannot open outfile.\n')
   ELSE
    err_WriteF('Cannot open \s.',[p])
   ENDIF
   p := 10
  CASE MEM
   err_WriteF('Unable to allocate memory for ')
   IF (pattern=NIL)
    err_WriteF('pattern.\n')
   ELSEIF (indata=NIL)
    err_WriteF('incoming data.\n')
   ELSE
    err_WriteF(p)
   ENDIF
   p := 20
  CASE "GRAM"
   err_WriteF('Gramwidth value must be between 1 and 512.\n')
   p := 10
  CASE "XDEP"
   err_WriteF('Xdepth value must be between 5 and 64\n' +
          '(and less than half the stereogram width).\n')
   p := 10
  CASE ARGS
   IF CtrlC()
    SetIoErr(0)
    err_WriteF('mk3d: ***Break\n')
    n:=0
    p:=20
   ELSE
    err_WriteF(xtrahelp)
    p := 5
   ENDIF
  CASE READ
   err_WriteF('Error while reading input file.\n')
   p := 10
  CASE "^C"
   err_WriteF('mk3d: ***Break\n')
   n := 0
   p := 20
  CASE "GURU"
   err_WriteF('GURU: $\h\n',exceptioninfo)
   n := 0
   p := 20
  DEFAULT
   err_WriteF('Extremely Awful Internal Error.  Mention following to author:\n')
   err_WriteF('\s\n',[exception])
   p := 20
 ENDSELECT
 err_Dispose()
ENDPROC p