(*$S+*)
PROGRAM ANADEXPIC;
(*$I-*)
  
CONST
  TXTMD = 29;                                       (* TEXT/NORMAL MODE     *)
  GRFMD = 28;                                       (* GRAPHICS MODE        *)
  CTRL  = 3;                                        (* CONTROL CHARACTER    *)
  NUL   = 0;                                        (* NUL TO CLEAR SCREEN  *)
  BELL  = 7;                                        (* TELL WHEN PIC DRAWN  *)
  LF    = 10;                                       (* LINE FEED            *)
  VT    = 11;                                       (* VERTICAL TAB         *)
  FF    = 12;                                       (* FORM FEED            *)
  CR    = 13;                                       (* CARRAGE RETURN       *)
  SP    = 32;                                       (* SPACE                *)
  
TYPE
  LINE = PACKED ARRAY [0..319] OF BOOLEAN;          (* FOR SWOPPING ARRAY   *)
  BLOCK = PACKED ARRAY [0..239,0..319] OF BOOLEAN;  (* PICTURE FORMAT       *)
  FOUR = 1..4;
  PICFORMAT = RECORD CASE FOUR OF
    1:(B: PACKED ARRAY [0..239,0..319] OF BOOLEAN); (* AS ABOVE             *)
    2:(C: PACKED ARRAY [0..9599] OF CHAR);          (* FOR CLEARING ARRAY   *)
    3:(Q: PACKED ARRAY [0..4863] OF INTEGER);       (* READING AND WRITING  *)
    4:(A: PACKED ARRAY [0..239] OF LINE);           (* SWOPPING             *)
  END; (* PIC FORMAT *)

VAR
  SCREEN:PICFORMAT;                                 (* THE DATA HOLDER      *)
  FOTO:FILE;                                        (* THE FOTO-FILE        *)
  SLBOX:TEXT;                                       (* THE SLIDE BOX        *)
  CH:CHAR;                                          (* FOR CONT. CHARS      *)
  COMM:CHAR;                                        (* THE COMMAND          *)
  MESSAGE:STRING;                                   (* A MESSAGE TO USER    *)
  YSTEP:INTEGER;                                    (* SIZE OF VERTICAL STEP*)
                                                    (* MUST DIVIDE INTO 240 *)
(*$IANADEXTRA.TEXT*)

PROCEDURE PNTBYT(C:CHAR);                           (* SENDS CHAR TO PRINTER*)
BEGIN
  UNITWRITE(8,C,1);
END; (* PNTBYT *)                                         

PROCEDURE LINEFEED;                                 (* SENDS A NEWLINE TO   *)
BEGIN                                               (* THE PRINTER          *)
  PNTBYT(CHR(CR));
  PNTBYT(CHR(LF));
END; (* LINE FEED *)

PROCEDURE PADOUT;                                   (* PADS OUT THE         *)
BEGIN                                               (* LINE SO THAT THE     *)
  PNTBYT(CHR(59));                                  (* PICTURE IS IN THE    *)
  PNTBYT(CHR(48));                                  (* CENTRE OF THE PAGE   *)
  PNTBYT(CHR(53));
  PNTBYT(CHR(48));
END; (* PAD OUT *)

FUNCTION BYTE(BIT0,BIT1,BIT2,BIT3,BIT4,BIT5:BOOLEAN):INTEGER;
VAR BAR:INTEGER;                                    (* BUILDS AN INTEGER OUT*) 
BEGIN                                               (* OF SIX BOOLEAN BITS  *)
  BAR := 0;
  IF BIT5 THEN BAR := BAR+1;              
  IF BIT4 THEN BAR := BAR+2;              
  IF BIT3 THEN BAR := BAR+4;               
  IF BIT2 THEN BAR := BAR+8;               
  IF BIT1 THEN BAR := BAR+16;
  IF BIT0 THEN BAR := BAR+32;
  BYTE := BAR;
END; (* BYTE *)

PROCEDURE SENDLINE(VAR LINE:BLOCK;SLICENO:INTEGER); (* TAKES A SLICE OF THE *)
VAR X,Y,SEND:INTEGER;                               (* SCREEN STARTING AT   *)
BEGIN                                               (* SLICENO AND PRINTS   *)
  Y := SLICENO;                                     (* EACH SEGMENT         *)
  FOR X := 0 TO 319 DO
    BEGIN
      IF YSTEP = 6 
        THEN SEND := BYTE(LINE[Y+0,X],LINE[Y+1,X],LINE[Y+2,X], (* FOR NORMAL*)
                          LINE[Y+3,X],LINE[Y+4,X],LINE[Y+5,X]);(* PICTURE   *)
      IF YSTEP = 3 
        THEN SEND := BYTE(LINE[Y+0,X],FALSE,LINE[Y+1,X], (* FOR LONG  *)
                          FALSE,LINE[Y+2,X],FALSE);      (* PICTURE   *)
      PNTBYT(CHR(SEND+64));
      IF YSTEP = 3 THEN PNTBYT(CHR(64)); 
    END;                                            (* THINK IT WAS CTRL    *)
  PNTBYT(CHR(54));                                  (* A RETURN SEQUENCE    *)
END; (* SEND LINE *)

PROCEDURE GETLABEL(VAR NAME,TITLE:STRING);          (* GETS NAME AND TITLE  *)
BEGIN                                               (* OF PICTUTE FROM USER *)
  NAME := '';
  TITLE := '';
  WRITELN;
  WRITE('Name  : ');
  READLN(NAME);
  WRITELN;
  WRITE('Title : ');
  READLN(TITLE);
END; (* GET LABEL *)

PROCEDURE SETUP;                                    (* ALLOWS USER TO CHOSE *)
VAR STATE:CHAR;                                     (* LONG OR NORMAL SIZE  *)
BEGIN
  REPEAT
    WRITELN;
    WRITE('Setup: N(ormal,W(ide :');
    READ(STATE); 
  UNTIL STATE IN ['N','W','n','w'];
  WRITELN;
  CASE STATE OF
    'N','n': YSTEP := 6;
    'W','w': YSTEP := 3;
  END;
END; (* SETUP *)
  
PROCEDURE PRINTLABEL(VAR NAME,TITLE:STRING);        (* SENDS THE PICTURE     *)
VAR I:INTEGER;                                      (* LABEL TO THE PRINTER  *)
BEGIN
  PNTBYT(CHR(TXTMD));
  FOR I := 1 TO 2 DO LINEFEED;
  IF NAME <> '' THEN
    BEGIN
      FOR I := 1 TO 10 DO PNTBYT(CHR(SP));
      FOR I := 1 TO LENGTH(NAME) DO PNTBYT(NAME[I]);
    END;
  LINEFEED;
  IF TITLE <> '' THEN
    BEGIN
      FOR I := 1 TO 10 DO PNTBYT(CHR(SP));
      FOR I := 1 TO LENGTH(TITLE) DO PNTBYT(TITLE[I]);
    END;
  FOR I := 1 TO 2 DO LINEFEED;
END; (* PRINT LABEL *)

PROCEDURE PRINTPIC;                                 (* PRINTS THE PICTURE   *)
VAR SLICENO:INTEGER;                                (* CURRENTLY IN THE     *)
    NAME,TITLE:STRING;                              (* SCREEN ARRAY TO THE  *)
BEGIN                                               (* PAPER TIGER PRINTER  *)
  WRITELN('Send array to printer... ');
  GETLABEL(NAME,TITLE);                             
  SETUP;
  LINEFEED;
  SLICENO := 0;                                   
  PNTBYT(CHR(GRFMD));                               (* PUTS PRINTER INTO    *)
  WHILE SLICENO <= 239 DO                           (* GRAPHICS MODE        *)
    BEGIN
      PADOUT;
      SENDLINE(SCREEN.B,SLICENO);
      SLICENO := SLICENO + YSTEP 
    END;
  PRINTLABEL(NAME,TITLE);
  MESSAGE := 'PIC PRINTED';
END; (* PRINT PIC *)                               
 
PROCEDURE GETFILE(VAR FLNAME:STRING; POSTFIX:STRING);(* PROMPTS FOR FILE    *)
BEGIN                                               (* NAME NO NEED TO TYPE *)
  WRITELN;                                          (* POSTFIX              *)
  WRITE('File Name : '); READLN(FLNAME);
  IF POS(POSTFIX,FLNAME) = 0 THEN FLNAME := CONCAT(FLNAME,POSTFIX);
END; (* GET FILE *)

PROCEDURE READPIC(FLNAME:STRING);                   (* READS IN A FOTO FILE *)
BEGIN
  RESET(FOTO,FLNAME);
  IF IORESULT <> 0 THEN 
     MESSAGE := ' * FOTO FILE NAME ERROR * '
  ELSE
    IF BLOCKREAD(FOTO,SCREEN.Q[0],19) <> 19 THEN
      MESSAGE := ' * ERROR IN READING FOTO FILE * '
    ELSE
      BEGIN
        CLOSE(FOTO);                                (* PICTURE READ IN      *)
        MESSAGE := 'PIC READ';                      (* SUCCESSFULLY         *)
        DRAWPIC;
      END;
END; (* READ PIC *)

PROCEDURE SETREAD;                                  (* GETS NAME OF FOTO    *)
VAR FLNAME:STRING;                                  (* FILE AND READS IT IN *)
BEGIN
  WRITELN('Read in foto file...');
  GETFILE(FLNAME,'.FOTO');
  READPIC(FLNAME);
END;

PROCEDURE WRITEPIC(FLNAME:STRING);                  (* WRITES TO A FOTO FILE*)
BEGIN                                               
  REWRITE(FOTO,FLNAME);                             
  IF IORESULT <> 0 THEN 
    MESSAGE := ' * FOTO FILE NAME ERROR * '
  ELSE
    IF BLOCKWRITE(FOTO,SCREEN.Q[0],19) <> 19 THEN
      MESSAGE := 'ERROR IN WRITING FOTO FILE'
    ELSE
      BEGIN
        CLOSE(FOTO,LOCK);                           (* PICTURE WRITTEN      *)
        MESSAGE := 'PIC WRITTEN';                   (* SUCCESSFULLY         *)
      END;
END; (* WRITEPIC *) 

PROCEDURE SETWRITE;                                 (* GETS FOTO FILE NAME  *)
VAR FLNAME:STRING;                                  (* AND WRITES TO IT     *)
BEGIN
  WRITELN('Write to a foto file... ');
  GETFILE(FLNAME,'.FOTO');
  WRITEPIC(FLNAME);
END;

PROCEDURE READBOX;                                  (* READS THE NAMES OF   *)
VAR BXNAME,FLNAME:STRING;                           (* THE FOTO FILES FROM  *)
BEGIN                                               (* A SLIDE BOX FILE     *)
  WRITELN('Read in a slide box... ');                (* AND DISPAYS EACH ONE *)
  GETFILE(BXNAME,'.TEXT');
  RESET(SLBOX,BXNAME);
  IF IORESULT <> 0 THEN 
    MESSAGE := ' * TEXT FILE NAME ERROR * '
  ELSE
    BEGIN
      WHILE NOT EOF(SLBOX) DO
        BEGIN
          READLN(SLBOX,FLNAME);
          IF ((FLNAME<>'') AND (IORESULT=0)) THEN
            BEGIN
              WRITELN(FLNAME);
              READPIC(FLNAME);
              WRITELN(MESSAGE);
            END;
        END;
      WRITE('Press any key: ');
      READ(KEYBOARD,CH);
      CLOSE(SLBOX);
      MESSAGE := 'SLIDE BOX READ';
    END;
END;
  
PROCEDURE GETCOMMAND;                               (* CLEARS T.V. SCREEN   *)
BEGIN                                               (* AND LISTS COMMANDS   *)
  REPEAT
    PAGE(OUTPUT);
    WRITELN(MESSAGE);
    WRITELN;
    WRITELN('           ***** ANADEXPIC *****      ');
    WRITELN;
    WRITELN;
    WRITELN('KEY : 1 to read foto file to array');
    WRITELN;
    WRITELN('      2 to write the array to foto file');
    WRITELN;
    WRITELN('      3 to read in a slide box file');
    WRITELN;
    WRITELN('      4 to send the array to printer');
    WRITELN;
    WRITELN('      5 to draw frame and save in array');
    WRITELN;
    WRITELN('      6 to draw the array on the screen');
    WRITELN;
    WRITELN('      7 to QUIT');
    WRITELN;
    WRITE('Choice: ');
    READ(KEYBOARD,COMM);
  UNTIL COMM IN ['1'..'7'];
END; (* GET COMMAND *)

BEGIN (* MAIN PROGRAM *)
  MESSAGE := '';
  REPEAT
    GETCOMMAND;
    CASE COMM OF
      '1': SETREAD;
      '2': SETWRITE;
      '3': READBOX;
      '4': PRINTPIC;
      '5': BEGIN FRAME; SAVEPIC; END;
      '6': BEGIN WRITELN('Draw array on screen...'); DRAWPIC; END;
      '7': WRITELN('QUIT');
    END;
  UNTIL COMM = '7';
END.