(* The Great Win32 Language Shootout http://dada.perl.it/shootout/

   contributed by Isaac Gouy (Modula2 novice)

   To compile: xc =m lists
   To run:     lists 16
*)

MODULE Lists;
<* m2extensions + *>
<* storage + *>

(* Prefer unqualified procedures *)
FROM LanguageShootout IMPORT N;

FROM STextIO IMPORT WriteString, WriteLn;
FROM SWholeIO IMPORT WriteCard;


(* We need an ADT let's implement a double-linked list *)
TYPE
   Node_Ptr = POINTER TO Queue_Node;
   Queue_Node =
      RECORD
         prev, next: Node_Ptr;
         item: CARDINAL;
      END;		
		
   Queue_Ptr = POINTER TO Queue_Type;
   Queue_Type =
      RECORD
         first, last: Node_Ptr;
         length: CARDINAL;
      END;


   Queue_Positions = (First, Last);	


VAR node, node2: Node_Ptr;


PROCEDURE Initialize(VAR q: Queue_Ptr);
BEGIN
   NEW(q);
   q^.length := 0;
   q^.first := NIL;
   q^.last := NIL;
END Initialize;


PROCEDURE Add(position: Queue_Positions; VAR q: Queue_Ptr; item: CARDINAL);
BEGIN
   NEW(node);
   node^.item := item;
   INC(q^.length);

   IF q^.length = 1 THEN
      node^.prev := NIL;
      node^.next := NIL;
      q^.first := node;
      q^.last := node;
   ELSE
      IF position = First THEN
         node^.prev := NIL;
         node^.next := q^.first;
         q^.first^.prev := node;
         q^.first := node;
      ELSE
         node^.prev := q^.last;
         node^.next := NIL;
         q^.last^.next := node;
         q^.last := node;
      END;
   END;
END Add;


PROCEDURE Remove(position: Queue_Positions; VAR q: Queue_Ptr): CARDINAL;
   VAR item: CARDINAL;
BEGIN
   IF q^.length = 0 THEN
      RETURN 0;
   END;

   IF position = First THEN
      node := q^.first;
   ELSE
      node := q^.last;
   END;

   item := node^.item;
   DEC(q^.length);

   IF q^.length = 0 THEN
      q^.first := NIL;
      q^.last := NIL;
   ELSE
      IF position = First THEN
         q^.first := node^.next;
	 q^.first^.prev := NIL;
      ELSE
         q^.last := node^.prev;
	 q^.last^.next := NIL;	
      END;
   END;
   DISPOSE(node);
   RETURN item;
END Remove;


PROCEDURE Dispose(VAR q: Queue_Ptr);
BEGIN
   WHILE q^.first # NIL DO
      node := q^.first^.next;
      DISPOSE(q^.first);
      q^.first := node;
   END;
   DISPOSE(q);
END Dispose;


PROCEDURE Copy(q: Queue_Ptr; VAR qcopy: Queue_Ptr);
BEGIN
   node2 := q^.first ;
   WHILE node2 # NIL DO
      Add(Last, qcopy, node2^.item);
      node2 := node2^.next;
   END;
END Copy;


PROCEDURE Reverse(VAR q: Queue_Ptr);
BEGIN
   node := q^.first;
   q^.first := q^.last;
   q^.last := node;
   WHILE node # NIL DO
      node2 := node^.next;
      node^.next := node^.prev;
      node^.prev := node2;
      node := node2;
   END;
END Reverse;


PROCEDURE Length(q: Queue_Ptr): CARDINAL;
BEGIN
   RETURN q^.length;
END Length;


PROCEDURE FirstItem(q: Queue_Ptr): CARDINAL;
BEGIN
   IF q^.length = 0 THEN
      RETURN 0;
   ELSE
      RETURN q^.first^.item;
   END;
END FirstItem;


PROCEDURE Equal(q,q2: Queue_Ptr): BOOLEAN;
BEGIN
   IF q^.length # q2^.length THEN
      RETURN FALSE;
   END;

   node := q^.first;
   node2 := q2^.first;
   WHILE node # NIL DO
      IF node^.item # node2^.item THEN
         RETURN FALSE;
      END;
      node := node^.next;
      node2 := node2^.next;
   END;
   RETURN TRUE;
END Equal;


CONST SIZE = 10000;

VAR L1, L2, L3: Queue_Ptr;
    i, m, n, lengthL1: CARDINAL;

BEGIN
   n := N();

   FOR m := 1 TO n DO
      NEW(L1);
      Initialize(L1);
      FOR i := 1 TO SIZE DO
         Add(Last, L1, i);
      END;

      NEW(L2);
      Initialize(L2);
      Copy(L1, L2);

      NEW(L3);
      Initialize(L3);
      WHILE Length(L2) > 0 DO
         Add(Last, L3, ( Remove(First, L2)) );
      END;

      WHILE Length(L3) > 0 DO
         Add(Last, L2, ( Remove(Last, L3) ));
      END;

      Reverse(L1);

      IF FirstItem(L1) # SIZE THEN
         WriteString("First item of L1 # SIZE"); WriteLn;
      END;
      IF NOT Equal(L1, L2) THEN
         WriteString("L1 # L2"); WriteLn;
      END;

      lengthL1 := Length(L1);

      Dispose(L1);
      Dispose(L2);
      Dispose(L3);
   END;

   WriteCard(lengthL1,1); WriteLn;
END Lists.