

PROGRAM DRAW4;

uses screenops;

CONST SHOWARPD = '#';
      SHOWARPL = ' ';

TYPE SETOFCHAR = SET OF CHAR;


VAR  THREAD : ARRAY[1..80] OF INTEGER;  {For threading info}
     TREADL : ARRAY[1..80] OF INTEGER;  {For treadling info}
     TIE1, TIE2, TIE3 : ARRAY[1..10] OF INTEGER;  {For tieup info}
     COLOR1, COLOR2 : ARRAY[1..80] OF CHAR;  {For color info}
     I, J, K, MAXSIZE, HORIZLEN, VERTLEN, TABBYA, TABBYB  : INTEGER;
     REM : STRING[40];
     OKSET : SETOFCHAR;
     GOOD : BOOLEAN;
     CH, BS, CR, BELL : CHAR;
     FT : TEXT;
     
     
PROCEDURE MENU; FORWARD;

PROCEDURE CLEARSCREEN;
BEGIN
  sc_clr_screen;
END;

PROCEDURE DPIXEL;  {Dark pixel for IDS-460 graphics}
BEGIN
  WRITE(FT,CHR(85),CHR(42),CHR(85),CHR(42),CHR(85),CHR(42),CHR(85));
END;

PROCEDURE LPIXEL;  {Light pixel for IDS-460 graphics}
BEGIN
  WRITE(FT,CHR(0),CHR(0),CHR(0),CHR(0),CHR(0),CHR(0),CHR(0));
END;

FUNCTION GETCHAR(OKSET : SETOFCHAR) : CHAR;
VAR CH   : CHAR;
    GOOD : BOOLEAN;
    
BEGIN
  CR := CHR(13);
  BELL := CHR(7);
  REPEAT
    READ(KEYBOARD,CH);
    IF EOLN(KEYBOARD) THEN CH := CR;
    GOOD := CH IN OKSET;
    IF NOT GOOD THEN
    WRITE(BELL) ELSE
    IF CH IN [' '..CHR(125)] THEN
    WRITE(CH)
  UNTIL GOOD;
  GETCHAR := CH;
END;

  
  { Used by GETINTEGER for bomb proof numerical data entry }
  
FUNCTION GETNUM(MAXVAL,MINVAL : REAL; PTOK : BOOLEAN):REAL;

TYPE SETOFCHAR = SET OF CHAR;

VAR FIRSTCHAR, LASTCHAR    : BOOLEAN;
    NUMSET, GETSET, OKSET  : SETOFCHAR;
    NUMSTRTEMP             : STRING[10];
    S1                     : STRING[1];
    LEN, MAXLEN            : INTEGER;
    NUM                    : REAL;
    CR, BS, BELL           : CHAR;
    


FUNCTION FPNUM(FPSTR : STRING) : REAL;
VAR POWER, SIGN, I : INTEGER;
    NUM : REAL;
    
BEGIN
  IF FPSTR[1] = '-' THEN
  BEGIN
    SIGN := -1;
    DELETE(FPSTR,1,1);
  END ELSE
  SIGN := 1;
  
  POWER := POS('.',FPSTR);
  IF POWER <> 0 THEN
  BEGIN
    DELETE(FPSTR,POWER,1);
    POWER := LENGTH(FPSTR)- POWER +1;
  END;
  NUM := 0;
  FOR I := 1 TO LENGTH(FPSTR) DO
  NUM := 10 * NUM + (ORD(FPSTR[I]) - ORD('0'));
  FPNUM := SIGN * NUM/PWROFTEN(POWER);
END;

BEGIN
  CR := CHR(13); BS := CHR(8); BELL := CHR(7);
  NUMSET := ['0'..'9'];
  IF MINVAL < 0 THEN OKSET := NUMSET + ['-'] ELSE OKSET := NUMSET;
  IF PTOK THEN MAXLEN := 8 ELSE MAXLEN := 7;
  S1 := ' '; NUMSTRTEMP := '';
  
  REPEAT
    LEN := LENGTH(NUMSTRTEMP);
    FIRSTCHAR := (LEN=0);
    LASTCHAR := (LEN=MAXLEN);
    
    IF PTOK THEN OKSET := OKSET + ['.'] ELSE
    OKSET := OKSET - ['.'];
    
    IF FIRSTCHAR THEN GETSET := OKSET ELSE
    IF LASTCHAR THEN GETSET := [CR,BS] ELSE
    GETSET := OKSET + [CR,BS] - ['-'];
    
    S1[1] := GETCHAR(GETSET);
    IF S1 = '.' THEN PTOK := FALSE;
    
    IF S1[1] IN OKSET THEN
    BEGIN
      NUMSTRTEMP := CONCAT(NUMSTRTEMP,S1);
      IF S1[1] IN NUMSET THEN
      BEGIN
        NUM := FPNUM(NUMSTRTEMP);
        IF (NUM > MAXVAL) OR (NUM < MINVAL) THEN
        BEGIN
          WRITE(CHR(7));
          WRITE(BS,' ',BS);
          DELETE(NUMSTRTEMP,LEN+1,1);
        END;
      END;
    END ELSE
    IF S1[1] = BS THEN
    BEGIN
      IF POS('.',NUMSTRTEMP) = LEN THEN
      PTOK := TRUE;
      WRITE(BS,' ',BS);
      DELETE(NUMSTRTEMP,LEN,1);
    END;
    
  UNTIL S1[1] = CR; WRITELN;
  GETNUM := FPNUM(NUMSTRTEMP);
END;



FUNCTION GETINTEGER(PROMPT : STRING; MAXVAL, MINVAL : INTEGER) : INTEGER;
VAR POINTOK : BOOLEAN;  {For bomb proof entry of numerical data}
    EOL : STRING[2];
BEGIN
  WRITE(PROMPT,CHR(27),CHR(116));  {Erase to end of line for TV-925 Term.}
  POINTOK := FALSE;
  GETINTEGER := TRUNC(GETNUM(MAXVAL,MINVAL,FALSE));
END;






PROCEDURE THREADING;  {Color and weave threading entry routine}

VAR COUNT, RPTFAC, RPTSEQ, I, J, K : INTEGER;
    {RPTFAC = Repeat factor, RPTSEQ = Repeat sequence}
    TEMP : ARRAY [1..80] OF INTEGER; {Temp array for repeat sequence}
    TEMPC : ARRAY [1..80] OF CHAR;  {Temp array for color repeat sequence}
    OKSET : SETOFCHAR;
    

BEGIN
  CLEARSCREEN;
  REM := '';
  WRITELN;
  WRITELN('ENTER ANY COMMENTS YOU MAY WANT UP TO 40 CHARACTERS--IF YOU');
  WRITELN('DON''T WANT ANY COMMENTS ---- PRESS <RETURN>');
  WRITELN;
  WRITELN('                  >----------------------------------------<');
  WRITE('ENTER COMMENTS --> ');
  READLN(REM);
  WRITELN;
  WRITELN('ENTER THE MAXIMUM NUMBER OF THREADS YOU WANT IN YOUR DRAWDOWN');
  WRITELN('THE MINIMUM SHOULD BE ONE REPEAT LENGTH AND THE MAXIMUM IS 80');
  WRITELN;
  MAXSIZE := GETINTEGER('HOW MANY WARP THREADS ?---> ',80,1);
  WRITELN;
  RPTSEQ := GETINTEGER('HOW MANY THREADS IN A REPEAT ?--->',80,1);
  RPTFAC := MAXSIZE DIV RPTSEQ;
  HORIZLEN := RPTSEQ * RPTFAC;
  WRITELN;
  WRITELN;
  WRITELN;
  WRITELN('                       ENTER YOUR THREADING REPEAT SEQUENCE');
  WRITELN('                              FOR ',RPTSEQ:3,' THREADS AND');
  WRITELN('                                   4 HARNESSES');
  WRITELN;
  FOR I := 1 TO RPTSEQ DO
  BEGIN
    WRITE('NO. ',I:2,' THREAD ');
    TEMP[I] := GETINTEGER(' TO HARNESS NO.--->  ',4,1);
  END;
  J := 1;
  FOR I := 1 TO RPTFAC DO
    BEGIN
      FOR K := 1 TO RPTSEQ DO
      BEGIN
        THREAD[J] := TEMP[K];
        J := J + 1
      END;
    END;
  CLEARSCREEN;
  WRITELN;
  WRITELN('THREADING SEQUENCE IS----->');
  WRITELN;
  COUNT := 0;
  FOR I := 1 TO HORIZLEN DO
  BEGIN
    WRITE(THREAD[I]:3);
    COUNT := COUNT + 1;
    IF COUNT MOD 25 = 0 THEN
    WRITELN;
  END;
  WRITELN;
  WRITELN;
  OKSET := [CHR(13)];
  WRITE('                  PRESS <RETURN> TO CONTINUE');
  CH := GETCHAR(OKSET);
  IF CH = CHR(13) THEN
  CLEARSCREEN;
  WRITELN;
  WRITELN;
  WRITELN('ENTER YOUR WARP THREAD COLOR REPEAT SEQUENCE WITH EITHER ');
  WRITELN('"D" OR "L" FOR EACH THREAD FOR ',RPTSEQ,' THREADS');
  WRITELN;
  OKSET := ['D','d','L','l'];
  FOR I := 1 TO RPTSEQ DO
  BEGIN
    WRITE('NO. ',I:2,' THREAD COLOR --> ');
    TEMPC[I] := GETCHAR(OKSET);
    WRITELN;
  END;
  WRITELN;
  WRITELN;
  J := 1;
  FOR I := 1 TO RPTFAC DO
    BEGIN
      FOR K := 1 TO RPTSEQ DO
      BEGIN
        COLOR1[J] := TEMPC[K];
        J := J + 1
      END;
    END;
  CLEARSCREEN;
  WRITELN('WARP THREAD COLOR SEQUENCE IS --->');
  WRITELN;
  COUNT := 0;
  FOR I := 1 TO HORIZLEN DO
  BEGIN
    WRITE(COLOR1[I]:3);
    COUNT := COUNT + 1;
    IF COUNT MOD 25 = 0 THEN
    WRITELN;
  END;
  WRITELN;
  WRITELN;
  WRITELN;
  WRITELN;
  OKSET := [CHR(13)];
  WRITE('                  PRESS <RETURN> TO CONTINUE');
  CH := GETCHAR(OKSET);
  IF CH = CHR(13) THEN
  EXIT(THREADING);
END;


PROCEDURE PTHREADING;  {Plain drawdown threading entry routine}
VAR COUNT, RPTFAC, RPTSEQ, I, J, K : INTEGER;
    TEMP : ARRAY[1..80] OF INTEGER;
    TEMPC : ARRAY[1..80] OF CHAR;
    OKSET : SETOFCHAR;
  
  BEGIN
  CLEARSCREEN;
  REM := '';
  WRITELN('ENTER ANY COMMENTS YOU MAY HAVE UP TO 40 CHARACTERS--IF YOU');
  WRITELN('DON''T WANT ANY COMMENTS -------- PRESS <RETURN>');
  WRITELN;
  WRITELN('                  >---------------------------------------<');
  WRITE('ENTER COMMENTS --> ');
  READLN(REM);
  WRITELN;
  WRITELN('ENTER THE MAXIMUM NUMBER OF THREADS YOU WANT IN YOUR DRAWDOWN');
  WRITELN('THE MINIMUM SHOULD BE ONE REPEAT LENGTH AND THE MAXIMUM IS 80');
  WRITELN;
  MAXSIZE := GETINTEGER('HOW MANY WARP THREADS DO YOU WANT ??---> ',80,1);
  WRITELN;
  RPTSEQ := GETINTEGER('HOW MANY THREADS IN A REPEAT ?--->',80,1);
  RPTFAC := MAXSIZE DIV RPTSEQ;
  HORIZLEN := RPTSEQ * RPTFAC;
  WRITELN;
  WRITELN;
  WRITELN;
  WRITELN('                       ENTER YOUR THREADING REPEAT SEQUENCE');
  WRITELN('                              FOR ',RPTSEQ:3,' THREADS AND');
  WRITELN('                                   4 HARNESSES');
  WRITELN;
  FOR I := 1 TO RPTSEQ DO
  BEGIN
    WRITE('NO. ',I:2,' THREAD ');
    TEMP[I] := GETINTEGER(' TO HARNESS NO.--->  ',4,1);
  END;
  J := 1;
  FOR I := 1 TO RPTFAC DO
    BEGIN
      FOR K := 1 TO RPTSEQ DO
      BEGIN
        THREAD[J] := TEMP[K];
        J := J + 1
      END;
    END;
  WRITELN;
  WRITELN('THREADING SEQUENCE IS----->');
  WRITELN;
  COUNT := 0;
  FOR I := 1 TO HORIZLEN DO
  BEGIN
    WRITE(THREAD[I]:3);
    COUNT := COUNT + 1;
    IF COUNT MOD 25 = 0 THEN
    WRITELN;
  END;
WRITELN;
WRITELN;
WRITELN;
OKSET := [CHR(13)];
WRITE('                  PRESS <RETURN> TO CONTINUE');
CH := GETCHAR(OKSET);
IF CH = CHR(13) THEN
EXIT(PTHREADING);
END;


PROCEDURE TYEUP;  {Treadle tieup entry routine}
BEGIN
  CLEARSCREEN;
  WRITE('WHAT TREADLE DO YOU WANT');
  TABBYA := GETINTEGER(' FOR TABBY "A" ? --> ',6,1);
  WRITELN;
  WRITE('WHAT TREADLE DO YOU WANT');
  TABBYB := GETINTEGER(' FOR TABBY "B" ? --> ',6,1);
  WRITELN;
  WRITELN('          --> ENTER THE TREADLE TIEUP TO THE HARNESSES <--');
  WRITELN;
  WRITELN('           IF YOU WANT A TREADLE TIED TO ONLY ONE HARNESS');
  WRITELN('           THEN ENTER THE SAME HARNESS NO. THREE TIMES OR');
  WRITELN('           IF YOU WANT A TREADLE TIED TO TWO HARNESSES THEN');
  WRITELN('           REPEAT EITHER OF THE HARNESSES ONCE OR IF YOU WANT');
  WRITELN('           A TREADLE TIED TO THREE DIFFERENT HARNESSES THEN');
  WRITELN('           ENTER THE HARNESS NUMBERS....');
  WRITELN;
  FOR I := 1 TO 6 DO
  BEGIN
    WRITE('TREADLE ',I:2);
    TIE1[I] := GETINTEGER(' TO ---> ',4,1);
    TIE2[I] := GETINTEGER('          AND ---> ',4,1);
    TIE3[I] := GETINTEGER('          AND ---> ',4,1);
    WRITELN;
  END;
WRITELN;
WRITELN('YOUR "A" TABBY IS TREADLE  ',TABBYA);
WRITELN('YOUR "B" TABBY IS TREADLE  ',TABBYB);
WRITELN;
WRITELN('YOUR TIEUP IS -------->');
WRITELN;
FOR I := 1 TO 6 DO
BEGIN
  WRITE('TREADLE',I:2, ' TO HARNESS NUMBERS',TIE1[I]:2,' -',TIE2[I]:2);
  WRITELN(' -',TIE3[I]:2);
END;
WRITELN;
WRITELN;
OKSET := [CHR(13)];
WRITE('                   PRESS <RETURN> TO CONTINUE');
CH := GETCHAR(OKSET);
IF CH = CHR(13) THEN
EXIT(TYEUP);
END;




PROCEDURE TREADLING;  {Color and weave treadling sequence entry routine}
VAR COUNT, RPTSEQ, RPTFAC, I, J, K : INTEGER;
    TEMP : ARRAY[1..80] OF INTEGER;
    TEMPC : ARRAY[1..80] OF CHAR;
    OKSET : SETOFCHAR;
    
BEGIN
  CLEARSCREEN;
  RPTSEQ := GETINTEGER('HOW MANY TREADLINGS IN A REPEAT ?--->',80,1);
  RPTFAC := MAXSIZE DIV RPTSEQ;
  VERTLEN := RPTSEQ * RPTFAC;
  WRITELN;
  WRITELN;
  WRITELN;
  WRITELN('                       ENTER YOUR TREADLEING REPEAT SEQUENCE');
  WRITELN('                              FOR ',RPTSEQ:3,' TREADLINGS AND');
  WRITELN('                                   4 HARNESSES');
  WRITELN;
  FOR I := 1 TO RPTSEQ DO
  BEGIN
    WRITE('FOR WARP THREAD ',I:2);
    TEMP[I] := GETINTEGER(' TREADLE NO.--->  ',6,1);
  END;
  J := 1;
  FOR I := 1 TO RPTFAC DO
    BEGIN
      FOR K := 1 TO RPTSEQ DO
      BEGIN
        TREADL[J] := TEMP[K];
        J := J + 1
      END;
    END;
  
  WRITELN('TREDLING SEQUENCE IS------>');
  WRITELN;
  COUNT := 0;
  FOR I := 1 TO VERTLEN DO
  BEGIN
    WRITE(TREADL[I]:3);
    COUNT := COUNT + 1;
    IF COUNT MOD 25 = 0 THEN
    WRITELN;
  END;
  WRITELN;
  WRITELN;
  WRITELN;
  WRITELN;
  OKSET := [CHR(13)];
  WRITE('                 PRESS <RETURN> TO CONTINUE');
  CH := GETCHAR(OKSET);
  IF CH = CHR(13) THEN
  CLEARSCREEN;
  OKSET := ['D','d','L','l'];
  WRITELN;
  WRITELN;
  WRITELN('ENTER YOUR WEFT COLOR SEQUENCE EITHER "D" OR "L"');
  WRITELN('FOR EACH PICK FOR ',RPTSEQ:3,' PICKS');
  WRITELN;
  FOR I := 1 TO RPTSEQ DO
  BEGIN
    WRITE('NO. ',I:2,' THREAD COLOR --> ');
    TEMPC[I] := GETCHAR(OKSET);
    WRITELN;
  END;
  WRITELN;
  WRITELN;
  J := 1;
  FOR I := 1 TO RPTFAC DO
    BEGIN
      FOR K := 1 TO RPTSEQ DO
      BEGIN
        COLOR2[J] := TEMPC[K];
        J := J + 1
      END;
  END;
  WRITELN;
  WRITELN;
  WRITELN('PICK COLOR SEQUENCE IS --->');
  WRITELN;
  COUNT := 0;
  FOR I := 1 TO VERTLEN DO
  BEGIN
    WRITE(COLOR2[I]:3);
    COUNT := COUNT + 1;
    IF COUNT MOD 25 = 0 THEN
    WRITELN;
  END;
  WRITELN;
  WRITELN;
  WRITELN;
  OKSET := [CHR(13)];
  WRITE('                  PRESS <RETURN> TO CONTINUE');
  CH := GETCHAR(OKSET);
  IF CH = CHR(13) THEN
  EXIT(TREADLING);
END;
      
      



PROCEDURE PTREADLING;  {Plain drawdown treadling sequence entry routine}
VAR COUNT, RPTFAC, RPTSEQ, I, J, K : INTEGER;
    TEMP : ARRAY[1..80] OF INTEGER;
    OKSET : SETOFCHAR;
BEGIN
  CLEARSCREEN;
  RPTSEQ := GETINTEGER('HOW MANY TREADLINGS IN A REPEAT ?--->',80,1);
  RPTFAC := MAXSIZE DIV RPTSEQ;
  VERTLEN := RPTFAC * RPTSEQ;
  WRITELN;
  WRITELN;
  WRITELN;
  WRITELN('                       ENTER YOUR TREADLEING REPEAT SEQUENCE');
  WRITELN('                              FOR ',RPTSEQ:3,' TREADLINGS AND');
  WRITELN('                                   4 HARNESSES');
  WRITELN;
  FOR I := 1 TO RPTSEQ DO
  BEGIN
    WRITE('FOR WARP THREAD ',I:2);
    TEMP[I] := GETINTEGER(' TREADLE NO.--->  ',6,1);
  END;
  J := 1;
  FOR I := 1 TO RPTFAC DO
    BEGIN
      FOR K := 1 TO RPTSEQ DO
      BEGIN
        TREADL[J] := TEMP[K];
        J := J + 1
      END;
    END;
  WRITELN;
  WRITELN;
  WRITELN('TREDLING SEQUENCE IS------>');
  WRITELN;
  COUNT := 0;
  FOR I := 1 TO VERTLEN DO
  BEGIN
    WRITE(TREADL[I]:3);
    COUNT := COUNT + 1;
    IF COUNT MOD 25 = 0 THEN
    WRITELN;
  END;
  WRITELN;
  WRITELN;
  WRITELN;
  OKSET := [CHR(13)];
  WRITE('            PRESS <RETURN> TO CONTINUE');
  CH := GETCHAR(OKSET);
  IF CH = CHR(13) THEN
  EXIT(PTREADLING);
END;
      
PROCEDURE COPYTHRD;
VAR COUNT, I : INTEGER;

BEGIN
  CLEARSCREEN;
  WRITELN('                     **** AS DRAWN IN ****');
  WRITELN;
  WRITELN('    THIS PROCEDURE WILL MAKE YOUR TREADLING SEQUENCE THE SAME AS');
  WRITELN('    YOUR THREADING SEQUENCE---IF YOUR TABBY TIEUP IS TO 5 OR 6');
  WRITELN('    AND YOU USE ANY TABBY TREADLING THIS PROCEDURE WILL NOT WORK');
  WRITELN;
  WRITE('      DO YOU WANT TO PROCEED ?  Y OR N :--> ');
  READ(KEYBOARD,CH);
  IF CH IN ['Y','y'] THEN
  BEGIN
    VERTLEN := HORIZLEN;
    WRITELN;
    WRITELN;
    WRITELN('    COPYING THREADING SEQUENCE TO TREADLING SEQUENCE --->');
    FOR I := 1 TO HORIZLEN DO
    BEGIN
      TREADL[I] := THREAD[I];
      WRITE('.');
    END;
    WRITELN;
    WRITELN;
    WRITELN;
    WRITELN('YOUR TREADLING SEQUENCE IS ---> ');
    WRITELN;
    COUNT := 0;
    FOR I := 1 TO HORIZLEN DO
    BEGIN
      WRITE(TREADL[I]:3);
      COUNT := COUNT + 1;
      IF COUNT MOD 25 = 0 THEN
      WRITELN;
    END;
    WRITELN;
    WRITELN;
    OKSET := [CHR(13)];
    WRITELN('                   PRESS <RETURN> TO CONTINUE');
    CH := GETCHAR(OKSET);
    IF CH = CHR(13) THEN
    EXIT(COPYTHRD);
  END ELSE
  EXIT(COPYTHRD);
END;


(*$I DRAW4A.1.TEXT *)

