home *** CD-ROM | disk | FTP | other *** search
/ ftp.barnyard.co.uk / 2015.02.ftp.barnyard.co.uk.tar / ftp.barnyard.co.uk / cpm / walnut-creek-CDROM / CPM / EDUCATIN / K-CHING.LBR / CHANGES.MZD / CHANGES.MOD
Text File  |  2000-06-30  |  13KB  |  499 lines
  1. MODULE Changes; (* Reads from an editable, textbased, I Ching *)
  2. FROM  Files IMPORT
  3.                     FileSize, SetPos, NextPos,
  4.                     ReadByte, WriteByte, FILE;
  5. FROM  Texts IMPORT  ReadLine,OpenText,CloseText,
  6.                     TextFile, TEXT, input;
  7. FROM SYSTEM IMPORT BYTE, INP, OUT;
  8. FROM Strings IMPORT Delete, Pos, Length, Insert;
  9. FROM Terminal IMPORT GotoXY, ReadChar, ClearScreen;
  10. FROM StatusLn IMPORT UserWantsTo, Blank, Copyright, HitAny, Notice;
  11. FROM KScreen IMPORT SetVideo, VideoAttribute;
  12.  
  13. TYPE
  14.     BUFFER = ARRAY [0..47] OF CHAR;
  15.     str6 = ARRAY [0..5] OF CHAR;
  16.     lineray = ARRAY [1..64] OF str6;
  17.     matrx = ARRAY [0..9] OF ARRAY [0..9] OF BUFFER;
  18.  
  19. VAR
  20.    hx,hy: str6;
  21.    g,h,i,j,k,l,x,y: CARDINAL;
  22.    line : BUFFER;
  23.    question : BUFFER;
  24.    c: CHAR;
  25.    LOOPFLAG: BOOLEAN;
  26.    matrix: matrx;
  27.    hex: ARRAY [1..64] OF str6; (*ordered list of hexagram binary equivalents*)
  28.    t: TEXT;
  29.    b: BYTE;
  30.  
  31. PROCEDURE LOADHEX;
  32. BEGIN
  33.      hex[1]:='111111';
  34.      hex[2]:='000000';
  35.      hex[3]:='100010';
  36.      hex[4]:='010001';
  37.      hex[5]:='111010';
  38.      hex[6]:='010111';
  39.      hex[7]:='010000';
  40.      hex[8]:='000010';
  41.      hex[9]:='111011';
  42.      hex[10]:='110111';
  43.      hex[11]:='111000';
  44.      hex[12]:='000111';
  45.      hex[13]:='101111';
  46.      hex[14]:='111101';
  47.      hex[15]:='001000';
  48.      hex[16]:='000100';
  49.      hex[17]:='100110';
  50.      hex[18]:='011001';
  51.      hex[19]:='110000';
  52.      hex[20]:='000011';
  53.      hex[21]:='100101';
  54.      hex[22]:='101001';
  55.      hex[23]:='000001';
  56.      hex[24]:='100000';
  57.      hex[25]:='100111';
  58.      hex[26]:='111001';
  59.      hex[27]:='100001';
  60.      hex[28]:='011110';
  61.      hex[29]:='010010';
  62.      hex[30]:='101101';
  63.      hex[31]:='001110';
  64.      hex[32]:='011100';
  65.      hex[33]:='001111';
  66.      hex[34]:='111100';
  67.      hex[35]:='000101';
  68.      hex[36]:='101000';
  69.      hex[37]:='101011';
  70.      hex[38]:='110101';
  71.      hex[39]:='001010';
  72.      hex[40]:='010100';
  73.      hex[41]:='110001';
  74.      hex[42]:='100011';
  75.      hex[43]:='111110';
  76.      hex[44]:='011111';
  77.      hex[45]:='000110';
  78.      hex[46]:='011000';
  79.      hex[47]:='010110';
  80.      hex[48]:='011010';
  81.      hex[49]:='101110';
  82.      hex[50]:='011101';
  83.      hex[51]:='100100';
  84.      hex[52]:='001001';
  85.      hex[53]:='001011';
  86.      hex[54]:='110100';
  87.      hex[55]:='101100';
  88.      hex[56]:='001101';
  89.      hex[57]:='011011';
  90.      hex[58]:='110110';
  91.      hex[59]:='010011';
  92.      hex[60]:='110010';
  93.      hex[61]:='110011';
  94.      hex[62]:='001100';
  95.      hex[63]:='101010';
  96.      hex[64]:='010101';
  97. END LOADHEX;
  98.  
  99. PROCEDURE UpdateHeader;
  100. TYPE
  101.     STR5 = ARRAY [0..4] OF CHAR;
  102. VAR
  103.     line: ARRAY [0..63] OF CHAR;
  104.     S: STR5;
  105.     STRING: ARRAY [0..65] OF STR5;
  106.     INDEX: ARRAY [0..65] OF CARDINAL;
  107.     x,y,z,Offset: CARDINAL;
  108.     l: LONGINT;
  109.     position: CARDINAL;
  110.  
  111.  
  112. PROCEDURE Convert(CardInput:CARDINAL; VAR temp: ARRAY OF CHAR );
  113. VAR xx: CARDINAL;
  114. BEGIN
  115.  
  116.    xx:= CardInput DIV 10000;
  117.    temp[0]:= CHR(48+xx);
  118.    CardInput := CardInput - (xx*10000);
  119.  
  120.    xx:= CardInput DIV 1000;
  121.    temp[1]:= CHR(48+xx);
  122.    CardInput := CardInput - (xx*1000);
  123.  
  124.    xx:= CardInput DIV 100;
  125.    temp[2]:= CHR(48+xx);
  126.    CardInput := CardInput - (xx*100);
  127.  
  128.    xx:= CardInput DIV 10;
  129.    temp[3]:= CHR(48+xx);
  130.    CardInput := CardInput - (xx*10);
  131.  
  132.    xx:= CardInput;
  133.    temp[4]:= CHR(48+xx);
  134.  
  135. END Convert;
  136.  
  137.  
  138. BEGIN (* UpdateHeader *)
  139.     IF NOT OpenText(t,'I-CHING.') THEN HALT; END;
  140.  
  141.     FOR x := 0 TO 65 DO INDEX[x]:=0;
  142.                        STRING[x]:='00000';
  143.     END;
  144.     b:=STRING[0,0];
  145.  
  146.     WRITE(32C);
  147.  
  148.     x:=1; y:=0;
  149.     position:=0;
  150.  
  151.     REPEAT
  152.         ReadLine(t,line);
  153.         IF line[0]='@' THEN
  154.             INDEX[x]:= position;
  155.             GotoXY(x,10);
  156.             WRITE('*');
  157.             GotoXY(0,14);
  158.             WRITE(position,'===',x);
  159.             x:=x+1;
  160.         END;
  161.         position:= CARD(NextPos(TextFile(t)));
  162.         WRITE(33C,"=  line ",position:5);
  163.     UNTIL Pos('@@@',line)<>(HIGH(line)+1);
  164.  
  165.     FOR x := 1 TO 64 DO
  166.         Convert(INDEX[x],STRING[x]);
  167.         WRITE(33C,"=##string ",x);
  168.     END;
  169.  
  170.         Convert(INDEX[65],STRING[0]);
  171.             INDEX[65] := CARD(FileSize(TextFile(t)));
  172.         Convert(INDEX[65],STRING[65]);
  173.  
  174.     FOR x := 0 TO 65 DO
  175.         WRITELN(x,'==',STRING[x]);
  176.     END;
  177.  
  178.  
  179.     SetPos(TextFile(t),129L);
  180.     FOR x:= 0 TO 4 DO
  181.         b:= STRING[0,x];
  182.         WriteByte(TextFile(t),b);
  183.     END;
  184.  
  185.     Offset:=164-59;
  186. FOR z := 0 TO 7  DO
  187.     Offset:=Offset+(59);
  188.     FOR y := 1 TO 8 DO
  189.         SetPos(TextFile(t),LONG(Offset+(6*y)));
  190.         FOR x:= 0 TO 4 DO
  191.             b:= STRING[y+z*8,x];
  192.             WriteByte(TextFile(t),b);
  193.         END;
  194.     END;
  195. END;
  196.  
  197.     SetPos(TextFile(t),665L);
  198.     FOR x:= 0 TO 4 DO
  199.         b:= STRING[65,x];
  200.         WriteByte(TextFile(t),b);
  201.     END;
  202. CloseText(t);
  203. END UpdateHeader;
  204.  
  205.  
  206. PROCEDURE  Rand16():CARDINAL; (*generates 0-15 using the clock ports*)
  207. VAR test: CARDINAL;
  208. BEGIN
  209.     OUT(34,15);    (*POrt[34]:=15;*)
  210.     OUT(32,1);     (*port[32]:=1;*)
  211.     test:=INP(36);  (*test:=port[36];*)
  212.     test:=test DIV 10;
  213.     RETURN test;
  214. END Rand16;
  215.  
  216. PROCEDURE makepattern;
  217. VAR LL: ARRAY [0..5] OF CARDINAL;
  218. BEGIN
  219.  
  220.     LL[0]:= Rand16();
  221.     HitAny;
  222.  
  223.     LL[1]:= Rand16();
  224.     ClearScreen;
  225.   LOOP;
  226.           GotoXY(20,2); WRITE('[0] - to EXIT The Book of Changes');
  227.           GotoXY(20,5); WRITE('[1] - to Cast a Hexagram');
  228.           GotoXY(20,7); WRITE('[2] - to Retreive a manual casting');
  229.           GotoXY(20,19);WRITE('[*] - to reset Header after editing');
  230.         WRITELN;
  231.         ReadChar(c);
  232.     IF (c='0') THEN HALT END;
  233.     IF ( (c='1') OR (c='2') ) THEN EXIT; END;
  234.     IF (c='*') AND (UserWantsTo('Are you sure'))
  235.         THEN UpdateHeader;
  236.         ClearScreen;
  237.     END;
  238.   END;
  239.  
  240.     LL[2]:= Rand16();
  241.  
  242.         WRITELN;
  243.         WRITE('Enter your question >');
  244.         ReadLine(input,question);
  245.  
  246.         IF c='2' THEN
  247.             WRITELN();
  248.           LOOP;
  249.           LOOPFLAG:=TRUE;
  250.             WRITE('Input cast pattern {6789} >');
  251.             READLN(line);
  252.  
  253.             FOR j := 0 TO 5 DO
  254.                  l:=ORD(line[j]);
  255.  
  256.                  IF ( (l<54) OR (l>57) ) THEN LOOPFLAG:=FALSE; END;
  257.                  (*tests for incorrect input*)
  258.  
  259.                  IF l = 54 THEN hx[j] := '0'; hy[j] := '1'; END;
  260.                  IF l = 55 THEN hx[j] := '1'; hy[j] := '1'; END;
  261.                  IF l = 56 THEN hx[j] := '0'; hy[j] := '0'; END;
  262.                  IF l = 57 THEN hx[j] := '1'; hy[j] := '0'; END;
  263.             END;
  264.             IF LOOPFLAG THEN EXIT; END;
  265.           END; (*loop*)
  266.         ELSE
  267.             ClearScreen;
  268.  
  269.             LL[3]:= Rand16();
  270.                 HitAny;
  271.             LL[4]:= Rand16();
  272.                 HitAny;
  273.             LL[5]:= Rand16();
  274.  
  275.            FOR j := 0 TO 5 DO
  276.              IF LL[j] = 0 THEN
  277.                  hx[j] := '0';
  278.                  hy[j] := '1';
  279.              ELSIF ( (LL[j]=11) OR (LL[j]=13) OR (LL[j]=15) ) THEN
  280.                  hx[j] := '1';
  281.                  hy[j] := '0';
  282.              ELSIF ( (LL[j]=2) OR (LL[j]=4) OR (LL[j]=6) OR (LL[j]=8)
  283.                        OR (LL[j]=10) OR (LL[j]=12) OR (LL[j]=14) ) THEN
  284.                  hx[j] := '0';
  285.                  hy[j] := '0';
  286.              ELSIF ( (LL[j]=1) OR (LL[j]=3) OR (LL[j]=5) OR (LL[j]=7)
  287.                        OR (LL[j]=9) ) THEN
  288.                  hx[j] := '1';
  289.                  hy[j] := '1';
  290.              END;
  291.           END;
  292.         END;
  293. END makepattern;
  294.  
  295.  
  296. PROCEDURE findslot;
  297. BEGIN
  298.     FOR j := 1 TO 64 DO
  299.          IF hx = hex[j] THEN x := j;END;
  300.          IF hy = hex[j] THEN y := j;END;
  301.     END;
  302. END findslot;
  303.  
  304. PROCEDURE prepscreen;
  305. VAR yinbit,yangbit: ARRAY [0..11] OF  CHAR;
  306.     count: CARDINAL;
  307. BEGIN
  308.     ClearScreen;
  309.     c:=CHR(176);
  310.     FOR count := 0 TO 11 DO
  311.         yangbit[count]:=c;
  312.     END;
  313.     yinbit:=yangbit;
  314.     FOR count := 4 TO 7 DO
  315.         yinbit[count]:=' ';
  316.     END;
  317.  
  318. (*{DISPLAY LINES - GRAPHICS}*)
  319.     SetVideo(Cursor,FALSE);
  320.     FOR j := 0 TO 5 DO
  321.         GotoXY(1,6-j);
  322.         IF hex[x,j]='1' THEN WRITE(yangbit) ELSE WRITE(yinbit);END;
  323.         GotoXY(68,6-j);
  324.         IF hex[y,j]='1' THEN WRITE(yangbit) ELSE WRITE(yinbit);END;
  325.     END;
  326.  
  327. (* DISPLAY QUESTION *)
  328.     SetVideo(LoInverse,TRUE);
  329.     GotoXY(16,3); WRITE(question);
  330.     Blank(48-Length(question));
  331.  
  332. (* ONSCREEN HELP *)
  333.     Notice
  334.     (' Use UP & DOWN arrows to read lines, <ESC> to EXIT, <CR> for another');
  335.     SetVideo(LoInverse,FALSE);
  336.     GotoXY(1,8);
  337.     SetVideo(HiInverse,TRUE);
  338.     Blank(79);
  339.     GotoXY(0,8); WRITE(x);
  340.     GotoXY(71,8);WRITE(y);
  341.  
  342. END prepscreen;
  343.  
  344. PROCEDURE EXP(base,exp:CARDINAL):CARDINAL;
  345. VAR ret,cnt    : CARDINAL;
  346. BEGIN
  347.    ret := 1;
  348.    FOR cnt := 1 TO exp DO
  349.        ret := ret * base;
  350.    END;
  351.    IF exp=0 THEN ret:=1;END;
  352.    RETURN ret;
  353. END EXP;
  354.  
  355.  
  356. PROCEDURE getfile;
  357. VAR xx,yy,zz: CARDINAL;
  358.  
  359.     PROCEDURE Inset(x:CARDINAL): CARDINAL;
  360.     VAR Offset,temp,xxx,yyy,zzz: CARDINAL;
  361.         tt: TEXT;
  362.     BEGIN
  363.     IF NOT OpenText(tt,'I-CHING.') THEN HALT; END;
  364.        temp:= 0;
  365.        zzz:= (x-1) DIV 8;
  366.        yyy:= ((x-1) MOD 8);
  367.        Offset:= 164 + (59*zzz);
  368.        SetPos(TextFile(tt),LONG(Offset+(6*yyy)+6));
  369.        FOR xxx := 0 TO 4 DO
  370.            ReadByte(TextFile(tt),b);
  371.            temp:= temp + ((ORD(b)-48)*(EXP(10,4-xxx)));
  372.        END;
  373. CloseText(tt);
  374.        RETURN temp;
  375.     END Inset;
  376.  
  377. BEGIN
  378.     IF NOT OpenText(t,'I-CHING.') THEN HALT; END;
  379.  
  380.     SetVideo(HiInverse,TRUE);
  381.     SetPos(TextFile(t),LONG(Inset(x)));
  382.     ReadLine(t,line);
  383.     GotoXY(10,8);
  384.  
  385.     Delete(line,0,3);
  386.     WRITE(line);
  387.     SetVideo(HiInverse,FALSE);
  388.  
  389.     ReadLine(t,line);
  390.     FOR xx := 0 TO 7 DO
  391.         yy := 0;
  392.         REPEAT
  393.             matrix [xx,yy] := line;
  394.             yy := yy + 1;
  395.             ReadLine(t,line);
  396.         UNTIL (line[0]='[') OR (line[0]='@');
  397.         IF yy<9 THEN
  398.             FOR zz := yy TO 9 DO
  399.                 matrix [xx,zz] := '';
  400.             END;
  401.         END;
  402.     END;
  403.  
  404.     SetVideo(HiInverse,TRUE);
  405.     SetPos(TextFile(t),LONG(Inset(y)));
  406.     ReadLine(t,line);
  407.     Delete(line,0,3);
  408.     GotoXY(70-Length(line),8);
  409.     WRITE(line);
  410.     SetVideo(HiInverse,FALSE);
  411.  
  412.     ReadLine(t,line);
  413.     FOR xx := 8 TO 9 DO
  414.         yy := 0;
  415.         REPEAT
  416.             matrix [xx,yy] := line;
  417.             yy := yy + 1;
  418.             ReadLine(t,line);
  419.         UNTIL (line[0]='[') OR (line[0]='@');
  420.         IF yy<9 THEN
  421.             FOR zz := yy TO 9 DO
  422.                 matrix [xx,zz] := '';
  423.             END;
  424.         END;
  425.     END;
  426.     CloseText(t);
  427. END getfile;
  428.  
  429.  
  430.  
  431. PROCEDURE display;
  432. VAR sequence: ARRAY [0..10] OF CHAR;
  433.     c1: ARRAY [0..0] OF CHAR;
  434.     el: CARDINAL;
  435. BEGIN
  436.     IF NOT OpenText(t,'I-CHING.') THEN HALT; END;
  437.  
  438.     c1:='';
  439.     IF x=y THEN sequence:='01'
  440.     ELSE
  441.         sequence:='0189';
  442.         FOR j := 5 TO 0 BY -1  DO
  443.             c1[0]:=CHR(48+j+2);
  444.             IF (hex[x,j] <> hex[y,j])
  445.             THEN Insert(c1,sequence,2);
  446.             END;
  447.         END;
  448.     END;
  449.         k:= Length(sequence)-1;
  450.         j:= 0;
  451.         g:=0;
  452.     LOOP;
  453.         FOR el := 0 TO 9 DO
  454.             GotoXY(16,10+el);
  455.              WRITE('                                                   ');
  456.             GotoXY(16,10+el);
  457.              WRITE(matrix[j,el]);
  458.         END;
  459.       LOOP;
  460.         ReadChar(c);
  461.         IF    (c=12C) OR (c=30C) THEN g:= g+1; EXIT; (* DOWN *)
  462.           ELSIF ((c=13C) OR (c=5C))
  463.                 AND (g>0) THEN g:= g-1; c:='*'; EXIT;  (* UP *)
  464.           ELSIF (c=33C) THEN g:= 999; EXIT;            (* ESC *)
  465.           ELSIF (c=11C) OR (c=15C) THEN g:= 777; EXIT;            (* TAB *)
  466.         END;
  467.       END;(*LOOP*)
  468.         IF    g=999 THEN EXIT;
  469.           ELSIF g=777 THEN EXIT;
  470.           ELSIF (g=0) AND (c=13C) OR (c=5C) THEN g:=k;
  471.           ELSIF g>k THEN g:=0;
  472.         END;
  473.  
  474.         IF g<777 THEN j:= (ORD(sequence[g])-48);
  475.         END;
  476.     END; (*LOOP*)
  477.     CloseText(t);
  478. END display;
  479.  
  480.  
  481. BEGIN
  482.  
  483.     SetVideo(Cursor,FALSE);
  484.     Copyright('THE BOOK OF CHANGES','1.11 modula','1987',TRUE);
  485.     LOADHEX;
  486.   LOOP;
  487.         SetVideo(Cursor,TRUE);
  488.     makepattern;
  489.         SetVideo(Cursor,FALSE);
  490.  
  491.     findslot;
  492.     prepscreen;
  493.     getfile;
  494.     display;
  495.                                                           (* journal; *)
  496.     IF g=999 THEN EXIT;END;
  497.   END;
  498.     SetVideo(Cursor,TRUE);
  499. END Changes.