home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacMETH 3.2.1 / More Examples / Hennessy1.MOD < prev    next >
Encoding:
Text File  |  1992-10-09  |  5.6 KB  |  288 lines  |  [TEXT/MEDT]
  1. MODULE Hennessy1;
  2.  
  3. FROM Storage IMPORT ALLOCATE;
  4. FROM SYSTEM IMPORT VAL, TSIZE;
  5. FROM SYSTEM IMPORT REG, SETREG;
  6. FROM InOut IMPORT WriteLn, WriteString, WriteInt, Read, OpenOutput, CloseOutput;
  7.  
  8. CONST
  9.     permbase = 1.75;
  10.     queensbase = 1.83;
  11.     towersbase = 2.39;
  12.  
  13.     (* Towers *)
  14.     maxcells = 18;
  15.     stackrange = (*0..*) 3;
  16.  
  17.     (* Intmm, Mm *)
  18.     rowsize = 40;
  19.  
  20.     (* Perm *)
  21.     permrange = (*0 ..*)10;
  22.  
  23. TYPE
  24.     (* Towers *)
  25.     element = RECORD
  26.         discsize: LONGINT;
  27.         next: LONGINT;
  28.     END ;
  29.  
  30.     Proc = PROCEDURE;
  31.  
  32. VAR
  33.     fixed,floated: REAL; ch: CHAR;
  34.  
  35.     (* Perm *)
  36.     permarray: ARRAY [0..permrange] OF LONGINT;
  37.     pctr: LONGINT;
  38.  
  39.     (* Towers *)
  40.     stack: ARRAY [0..stackrange] OF LONGINT;
  41.     cellspace: ARRAY [0..maxcells] OF element;
  42.     freelist: LONGINT;
  43.     movesdone: LONGINT;
  44.  
  45.  
  46. (* global procedures *)
  47.  
  48. PROCEDURE Getclock (): LONGINT;
  49.     TYPE P = POINTER TO LONGINT;
  50.     VAR ticks: P; tk: LONGINT;
  51. BEGIN    ticks := VAL(P, 16AH);
  52.     tk := ticks^; RETURN TRUNCD(FLOATD(tk) * (1000.0D0/60.0D0) + 0.5D0)
  53. END Getclock;
  54.  
  55.  
  56.     (* Permutation program, heavily recursive, written by Denny Brown. *)
  57.  
  58.     PROCEDURE Swap (VAR a,b: LONGINT);
  59.         VAR t: LONGINT;
  60.     BEGIN t := a;  a := b;  b := t;
  61.     END Swap;
  62.  
  63.     PROCEDURE Initialize ();
  64.         VAR i: LONGINT;
  65.     BEGIN i := 1D;
  66.         WHILE i <= 7D DO
  67.             permarray[i] := i-1D;
  68.             INC(i)
  69.         END
  70.     END Initialize;
  71.  
  72.     PROCEDURE Permute (n: LONGINT);
  73.         VAR k: LONGINT;
  74.     BEGIN
  75.         pctr := pctr + 1D;
  76.         IF ( n#1D ) THEN
  77.             Permute(n-1D);
  78.             k := n-1D;
  79.             WHILE k >= 1D DO
  80.                 Swap(permarray[n], permarray[k]);
  81.                 Permute(n-1D);
  82.                 Swap(permarray[n], permarray[k]);
  83.                 DEC(k)
  84.             END
  85.        END
  86.     END Permute;
  87.  
  88. PROCEDURE Perm ();
  89.     VAR i: LONGINT;
  90. BEGIN
  91.     pctr := 0; i := 1D;
  92.     WHILE i <= 5D DO
  93.         Initialize();
  94.         Permute(7);
  95.         INC(i)
  96.     END ;
  97.     IF ( pctr # 43300D) THEN WriteString(" Error in Perm.$") END
  98. END Perm;
  99.  
  100.  
  101.     (*  Program to Solve the Towers of Hanoi *)
  102.  
  103.     PROCEDURE Makenull (s: LONGINT);
  104.     BEGIN stack[s] := 0
  105.     END Makenull;
  106.  
  107.     PROCEDURE Getelement (): LONGINT;
  108.         VAR temp: LONGINT;
  109.     BEGIN
  110.         IF ( freelist>0D) THEN
  111.             temp := freelist;
  112.             freelist := cellspace[freelist].next;
  113.         ELSE
  114.             WriteString("out of space   $")
  115.         END ;
  116.         RETURN (temp);
  117.     END Getelement;
  118.  
  119.     PROCEDURE Push(i,s: LONGINT);
  120.         VAR localel: LONGINT; errorfound: BOOLEAN;
  121.     BEGIN
  122.         errorfound := FALSE;
  123.         IF ( stack[s] > 0D) THEN
  124.             IF ( cellspace[stack[s]].discsize<=i ) THEN
  125.                 errorfound := TRUE;
  126.                 WriteString("disc size error$")
  127.             END
  128.         END ;
  129.         IF ( ~ errorfound ) THEN
  130.             localel := Getelement();
  131.             cellspace[localel].next := stack[s];
  132.             stack[s] := localel;
  133.             cellspace[localel].discsize := i
  134.         END
  135.     END Push;
  136.  
  137.     PROCEDURE Init (s,n: LONGINT);
  138.         VAR discctr: LONGINT;
  139.     BEGIN
  140.         Makenull(s); discctr := n;
  141.         WHILE discctr >= 1D DO
  142.             Push(discctr,s);
  143.             DEC(discctr)
  144.         END
  145.     END Init;
  146.  
  147.     PROCEDURE Pop (s: LONGINT): LONGINT;
  148.         VAR temp, temp1: LONGINT;
  149.     BEGIN
  150.         IF ( stack[s] > 0D) THEN
  151.             temp1 := cellspace[stack[s]].discsize;
  152.             temp := cellspace[stack[s]].next;
  153.             cellspace[stack[s]].next := freelist;
  154.             freelist := stack[s];
  155.             stack[s] := temp;
  156.             RETURN (temp1)
  157.         ELSE
  158.             WriteString("nothing to pop $")
  159.         END
  160.     END Pop;
  161.  
  162.     PROCEDURE Move (s1,s2: LONGINT);
  163.     BEGIN
  164.         Push(Pop(s1),s2);
  165.         movesdone := movesdone+1D;
  166.     END Move;
  167.  
  168.     PROCEDURE tower(i,j,k: LONGINT);
  169.         VAR other: LONGINT;
  170.     BEGIN
  171.         IF ( k=1D) THEN
  172.             Move(i,j);
  173.         ELSE
  174.             other := 6D-i-j;
  175.             tower(i,other,k-1D);
  176.             Move(i,j);
  177.             tower(other,j,k-1D)
  178.         END
  179.     END tower;
  180.  
  181. PROCEDURE Towers ();
  182.     VAR i: LONGINT;
  183. BEGIN i := 1D;
  184.     WHILE i <= LONG(maxcells) DO cellspace[i].next := i-1D; INC(i) END ;
  185.     freelist := maxcells;
  186.     Init(1,14);
  187.     Makenull(2);
  188.     Makenull(3);
  189.     movesdone := 0;
  190.     tower(1,2,14);
  191.     IF ( movesdone # 16383D) THEN WriteString(" Error in Towers.$") END
  192. END Towers;
  193.  
  194.  
  195.     (* The eight queens problem, solved 50 times. *)
  196.  
  197.     PROCEDURE Try(i: LONGINT; VAR q: BOOLEAN; VAR a, b, c: ARRAY OF BOOLEAN; VAR x: ARRAY OF LONGINT);
  198.         VAR j: LONGINT;
  199.     BEGIN
  200.         j := 0;
  201.         q := FALSE;
  202.         WHILE (~q) & (j # 8D) DO
  203.             j := j + 1D;
  204.             q := FALSE;
  205.             IF b[j] & a[i+j] & c[i-j+7D] THEN
  206.                 x[i] := j;
  207.                 b[j] := FALSE;
  208.                 a[i+j] := FALSE;
  209.                 c[i-j+7D] := FALSE;
  210.                 IF i < 8D THEN
  211.                     Try(i+1D,q,a,b,c,x);
  212.                     IF ~q THEN
  213.                         b[j] := TRUE;
  214.                         a[i+j] := TRUE;
  215.                         c[i-j+7D] := TRUE
  216.                     END
  217.                 ELSE q := TRUE
  218.                 END
  219.             END
  220.         END
  221.     END Try;
  222.  
  223.     PROCEDURE Doit ();
  224.         VAR i: LONGINT; q: BOOLEAN;
  225.             a: ARRAY [0..9] OF BOOLEAN;
  226.             b: ARRAY [0..17] OF BOOLEAN;
  227.             c: ARRAY [0..15] OF BOOLEAN;
  228.             x: ARRAY [0..9] OF LONGINT;
  229.     BEGIN
  230.         i := 0 - 7;
  231.         WHILE i <= 16D DO
  232.             IF (i >= 1D) & (i <= 8D) THEN a[i] := TRUE END ;
  233.             IF i >= 2D THEN b[i] := TRUE END ;
  234.             IF i <= 7D THEN c[i+7D] := TRUE END ;
  235.             i := i + 1D;
  236.         END ;
  237.         Try(1, q, b, a, c, x);
  238.         IF ( ~ q ) THEN WriteString(" Error in Queens.$") END
  239.     END Doit;
  240.  
  241. PROCEDURE Queens ();
  242.     VAR i: LONGINT;
  243. BEGIN i := 1D;
  244.     WHILE i <= 50D DO Doit(); INC(i) END
  245. END Queens;
  246.  
  247.  
  248. PROCEDURE Time(s: ARRAY OF CHAR; p: Proc; base, fbase: REAL);
  249.     VAR timer: LONGINT;
  250. BEGIN
  251.     timer := Getclock();
  252.     p;
  253.     timer := Getclock()-timer;
  254.     WriteString(s);
  255.     WriteInt(SHORT(timer), 8); WriteLn;
  256.     fixed := fixed + FLOAT(timer)*base;
  257.     floated := floated + FLOAT(timer)*fbase
  258. END Time;
  259.  
  260. PROCEDURE main2(i: INTEGER);
  261. BEGIN
  262.     fixed := 0.0;  floated := 0.0;
  263.     Time("Perm   ", Perm, permbase, permbase);
  264.     Time("Towers ", Towers, towersbase, towersbase);
  265.     Time("Queens ", Queens, queensbase, queensbase);
  266. END main2;
  267.  
  268. PROCEDURE main;
  269. BEGIN
  270.     fixed := 0.0;  floated := 0.0;
  271.     Time("Perm   ", Perm, permbase, permbase);
  272.     Time("Towers ", Towers, towersbase, towersbase);
  273.     Time("Queens ", Queens, queensbase, queensbase);
  274.     WriteLn;
  275.     main2(19);
  276. END main;
  277.  
  278. BEGIN
  279.  OpenOutput("H1.Mac");
  280.  WriteString("Hennessy1 mit MacMETH 3.2 : "); WriteLn;
  281.  WriteLn;
  282.     main;
  283.  CloseOutput;
  284.  WriteLn;
  285.  WriteString("any key to terminate. "); WriteLn;
  286.  Read(ch);
  287. END Hennessy1.
  288.