gitlab-pygments.rb 0.3.2

data/vendor/pygments-main/tests/examplefiles/SmallCheck.hs

@@ -0,0 +1,378 @@
+---------------------------------------------------------------------
+-- SmallCheck: another lightweight testing library.
+-- Colin Runciman, August 2006
+-- Version 0.2 (November 2006)
+--
+-- After QuickCheck, by Koen Claessen and John Hughes (2000-2004).
+---------------------------------------------------------------------
+
+module SmallCheck (
+  smallCheck, depthCheck,
+  Property, Testable,
+  forAll, forAllElem,
+  exists, existsDeeperBy, thereExists, thereExistsElem,
+  (==>),
+  Series, Serial(..),
+  (\/), (><), two, three, four,
+  cons0, cons1, cons2, cons3, cons4,
+  alts0, alts1, alts2, alts3, alts4,
+  N(..), Nat, Natural,
+  depth, inc, dec
+  ) where
+
+import Data.List (intersperse)
+import Control.Monad (when)
+import System.IO (stdout, hFlush)
+
+------------------ <Series of depth-bounded values> -----------------
+
+-- Series arguments should be interpreted as a depth bound (>=0)
+-- Series results should have finite length
+
+type Series a = Int -> [a]
+
+-- sum
+infixr 7 \/
+(\/) :: Series a -> Series a -> Series a
+s1 \/ s2 = \d -> s1 d ++ s2 d
+
+-- product
+infixr 8 ><
+(><) :: Series a -> Series b -> Series (a,b)
+s1 >< s2 = \d -> [(x,y) | x <- s1 d, y <- s2 d]
+
+------------------- <methods for type enumeration> ------------------
+
+-- enumerated data values should be finite and fully defined
+-- enumerated functional values should be total and strict
+
+-- bounds:
+-- for data values, the depth of nested constructor applications
+-- for functional values, both the depth of nested case analysis
+-- and the depth of results
+ 
+class Serial a where
+  series   :: Series a
+  coseries :: Serial b => Series (a->b)
+
+instance Serial () where
+  series   _ = [()]
+  coseries d = [ \() -> b
+               | b <- series d ]
+
+instance Serial Int where
+  series   d = [(-d)..d]
+  coseries d = [ \i -> if i > 0 then f (N (i - 1))
+                       else if i < 0 then g (N (abs i - 1))
+                       else z
+               | z <- alts0 d, f <- alts1 d, g <- alts1 d ]
+
+instance Serial Integer where
+  series   d = [ toInteger (i :: Int)
+               | i <- series d ]
+  coseries d = [ f . (fromInteger :: Integer->Int)
+               | f <- series d ]
+
+newtype N a = N a
+
+instance Show a => Show (N a) where
+  show (N i) = show i
+
+instance (Integral a, Serial a) => Serial (N a) where
+  series   d = map N [0..d']
+               where
+               d' = fromInteger (toInteger d)
+  coseries d = [ \(N i) -> if i > 0 then f (N (i - 1))
+                           else z
+               | z <- alts0 d, f <- alts1 d ]
+
+type Nat = N Int
+type Natural = N Integer
+
+instance Serial Float where
+  series d   = [ encodeFloat sig exp
+               | (sig,exp) <- series d,
+                 odd sig || sig==0 && exp==0 ]
+  coseries d = [ f . decodeFloat
+               | f <- series d ]
+             
+instance Serial Double where
+  series   d = [ frac (x :: Float)
+               | x <- series d ]
+  coseries d = [ f . (frac :: Double->Float)
+               | f <- series d ]
+
+frac :: (Real a, Fractional a, Real b, Fractional b) => a -> b
+frac = fromRational . toRational
+
+instance Serial Char where
+  series d   = take (d+1) ['a'..'z']
+  coseries d = [ \c -> f (N (fromEnum c - fromEnum 'a'))
+               | f <- series d ]
+
+instance (Serial a, Serial b) =>
+         Serial (a,b) where
+  series   = series >< series
+  coseries = map uncurry . coseries
+
+instance (Serial a, Serial b, Serial c) =>
+         Serial (a,b,c) where
+  series   = \d -> [(a,b,c) | (a,(b,c)) <- series d]
+  coseries = map uncurry3 . coseries
+
+instance (Serial a, Serial b, Serial c, Serial d) =>
+         Serial (a,b,c,d) where
+  series   = \d -> [(a,b,c,d) | (a,(b,(c,d))) <- series d]
+  coseries = map uncurry4 . coseries
+
+uncurry3 :: (a->b->c->d) -> ((a,b,c)->d)
+uncurry3 f (x,y,z) = f x y z
+
+uncurry4 :: (a->b->c->d->e) -> ((a,b,c,d)->e)
+uncurry4 f (w,x,y,z) = f w x y z
+
+two   :: Series a -> Series (a,a)
+two   s = s >< s
+
+three :: Series a -> Series (a,a,a)
+three s = \d -> [(x,y,z) | (x,(y,z)) <- (s >< s >< s) d]
+
+four  :: Series a -> Series (a,a,a,a)
+four  s = \d -> [(w,x,y,z) | (w,(x,(y,z))) <- (s >< s >< s >< s) d]
+
+cons0 :: 
+         a -> Series a
+cons0 c _ = [c]
+
+cons1 :: Serial a =>
+         (a->b) -> Series b
+cons1 c d = [c z | d > 0, z <- series (d-1)]
+
+cons2 :: (Serial a, Serial b) =>
+         (a->b->c) -> Series c
+cons2 c d = [c y z | d > 0, (y,z) <- series (d-1)]
+
+cons3 :: (Serial a, Serial b, Serial c) =>
+         (a->b->c->d) -> Series d
+cons3 c d = [c x y z | d > 0, (x,y,z) <- series (d-1)]
+
+cons4 :: (Serial a, Serial b, Serial c, Serial d) =>
+         (a->b->c->d->e) -> Series e
+cons4 c d = [c w x y z | d > 0, (w,x,y,z) <- series (d-1)]
+
+alts0 ::  Serial a =>
+            Series a
+alts0 d = series d
+
+alts1 ::  (Serial a, Serial b) =>
+            Series (a->b)
+alts1 d = if d > 0 then series (dec d)
+          else [\_ -> x | x <- series d]
+
+alts2 ::  (Serial a, Serial b, Serial c) =>
+            Series (a->b->c)
+alts2 d = if d > 0 then series (dec d)
+          else [\_ _ -> x | x <- series d]
+
+alts3 ::  (Serial a, Serial b, Serial c, Serial d) =>
+            Series (a->b->c->d)
+alts3 d = if d > 0 then series (dec d)
+          else [\_ _ _ -> x | x <- series d]
+
+alts4 ::  (Serial a, Serial b, Serial c, Serial d, Serial e) =>
+            Series (a->b->c->d->e)
+alts4 d = if d > 0 then series (dec d)
+          else [\_ _ _ _ -> x | x <- series d]
+
+instance Serial Bool where
+  series     = cons0 True \/ cons0 False
+  coseries d = [ \x -> if x then b1 else b2
+               | (b1,b2) <- series d ]
+
+instance Serial a => Serial (Maybe a) where
+  series     = cons0 Nothing \/ cons1 Just
+  coseries d = [ \m -> case m of
+                       Nothing -> z
+                       Just x  -> f x
+               |  z <- alts0 d ,
+                  f <- alts1 d ]
+
+instance (Serial a, Serial b) => Serial (Either a b) where
+  series     = cons1 Left \/ cons1 Right
+  coseries d = [ \e -> case e of
+                       Left x  -> f x
+                       Right y -> g y
+               |  f <- alts1 d ,
+                  g <- alts1 d ]
+
+instance Serial a => Serial [a] where
+  series     = cons0 [] \/ cons2 (:)
+  coseries d = [ \xs -> case xs of
+                        []      -> y
+                        (x:xs') -> f x xs'
+               |   y <- alts0 d ,
+                   f <- alts2 d ]
+
+-- Warning: the coseries instance here may generate duplicates.
+instance (Serial a, Serial b) => Serial (a->b) where
+  series = coseries
+  coseries d = [ \f -> g [f x | x <- series d]
+               | g <- series d ]              
+
+-- For customising the depth measure.  Use with care!
+
+depth :: Int -> Int -> Int
+depth d d' | d >= 0    = d'+1-d
+           | otherwise = error "SmallCheck.depth: argument < 0"
+
+dec :: Int -> Int
+dec d | d > 0     = d-1
+      | otherwise = error "SmallCheck.dec: argument <= 0"
+
+inc :: Int -> Int
+inc d = d+1
+
+-- show the extension of a function (in part, bounded both by
+-- the number and depth of arguments)
+instance (Serial a, Show a, Show b) => Show (a->b) where
+  show f = 
+    if maxarheight == 1
+    && sumarwidth + length ars * length "->;" < widthLimit then
+      "{"++(
+      concat $ intersperse ";" $ [a++"->"++r | (a,r) <- ars]
+      )++"}"
+    else
+      concat $ [a++"->\n"++indent r | (a,r) <- ars]
+    where
+    ars = take lengthLimit [ (show x, show (f x))
+                           | x <- series depthLimit ]
+    maxarheight = maximum  [ max (height a) (height r)
+                           | (a,r) <- ars ]
+    sumarwidth = sum       [ length a + length r 
+                           | (a,r) <- ars]
+    indent = unlines . map ("  "++) . lines
+    height = length . lines
+    (widthLimit,lengthLimit,depthLimit) = (80,20,3)::(Int,Int,Int)
+
+---------------- <properties and their evaluation> ------------------
+
+-- adapted from QuickCheck originals: here results come in lists,
+-- properties have depth arguments, stamps (for classifying random
+-- tests) are omitted, existentials are introduced
+
+newtype PR = Prop [Result]
+
+data Result = Result {ok :: Maybe Bool, arguments :: [String]}
+
+nothing :: Result
+nothing = Result {ok = Nothing, arguments = []}
+
+result :: Result -> PR
+result res = Prop [res]
+
+newtype Property = Property (Int -> PR)
+
+class Testable a where
+  property :: a -> Int -> PR
+
+instance Testable Bool where
+  property b _ = Prop [Result (Just b) []]
+
+instance Testable PR where
+  property prop _ = prop
+
+instance (Serial a, Show a, Testable b) => Testable (a->b) where
+  property f = f' where Property f' = forAll series f
+
+instance Testable Property where
+  property (Property f) d = f d
+
+evaluate :: Testable a => a -> Series Result
+evaluate x d = rs where Prop rs = property x d
+
+forAll :: (Show a, Testable b) => Series a -> (a->b) -> Property
+forAll xs f = Property $ \d -> Prop $
+  [ r{arguments = show x : arguments r}
+  | x <- xs d, r <- evaluate (f x) d ]
+
+forAllElem :: (Show a, Testable b) => [a] -> (a->b) -> Property
+forAllElem xs = forAll (const xs)
+
+thereExists :: Testable b => Series a -> (a->b) -> Property
+thereExists xs f = Property $ \d -> Prop $
+  [ Result
+      ( Just $ or [ all pass (evaluate (f x) d)
+                  | x <- xs d ] )
+      [] ] 
+  where
+  pass (Result Nothing _)  = True
+  pass (Result (Just b) _) = b
+
+thereExistsElem :: Testable b => [a] -> (a->b) -> Property
+thereExistsElem xs = thereExists (const xs)
+
+exists :: (Serial a, Testable b) =>
+            (a->b) -> Property
+exists = thereExists series
+
+existsDeeperBy :: (Serial a, Testable b) =>
+                    (Int->Int) -> (a->b) -> Property
+existsDeeperBy f = thereExists (series . f)
+ 
+infixr 0 ==>
+
+(==>) :: Testable a => Bool -> a -> Property
+True ==>  x = Property (property x)
+False ==> x = Property (const (result nothing))
+
+--------------------- <top-level test drivers> ----------------------
+
+-- similar in spirit to QuickCheck but with iterative deepening
+
+-- test for values of depths 0..d stopping when a property
+-- fails or when it has been checked for all these values
+smallCheck :: Testable a => Int -> a -> IO String
+smallCheck d = iterCheck 0 (Just d)
+
+depthCheck :: Testable a => Int -> a -> IO String
+depthCheck d = iterCheck d (Just d)
+
+iterCheck :: Testable a => Int -> Maybe Int -> a -> IO String
+iterCheck dFrom mdTo t = iter dFrom
+  where
+  iter :: Int -> IO String
+  iter d = do
+    let Prop results = property t d
+    (ok,s) <- check (mdTo==Nothing) 0 0 True results
+    maybe (iter (d+1))
+          (\dTo -> if ok && d < dTo
+                        then iter (d+1)
+                        else return s)
+          mdTo
+
+check :: Bool -> Int -> Int -> Bool -> [Result] -> IO (Bool, String)
+check i n x ok rs | null rs = do
+  let s = "  Completed "++show n++" test(s)"
+      y = if i then "." else " without failure."
+      z | x > 0     = "  But "++show x++" did not meet ==> condition."
+        | otherwise = ""
+  return (ok, s ++ y ++ z)
+
+check i n x ok (Result Nothing _ : rs) = do
+  progressReport i n x
+  check i (n+1) (x+1) ok rs
+
+check i n x f (Result (Just True) _ : rs) = do
+  progressReport i n x
+  check i (n+1) x f rs
+
+check i n x f (Result (Just False) args : rs) = do
+  let s = "  Failed test no. "++show (n+1)++". Test values follow."
+      s' = s ++ ": " ++ concat (intersperse ", " args)
+  if i then
+      check i (n+1) x False rs
+    else
+      return (False, s')
+
+progressReport :: Bool -> Int -> Int -> IO ()
+progressReport _ _ _ = return ()

data/vendor/pygments-main/tests/examplefiles/Sorting.mod

@@ -0,0 +1,470 @@
+IMPLEMENTATION MODULE Sorting;
+
+(* J. Andrea, Dec.16/91 *)
+(* This code may be freely used and distributed, it may not be sold. *)
+
+(* Adapted to ISO Module-2 by Frank Schoonjans  Feb 2004 *)
+
+FROM Storage IMPORT ALLOCATE;
+
+CONST
+   max_stack = 20;
+   n_small   = 6; (* use a simple sort for this size and smaller *)
+
+VAR
+  rtemp :REAL;
+  ctemp :CARDINAL;
+
+  L, R, n               :INTEGER;
+  top, bottom, lastflip :INTEGER;
+
+  tos            :CARDINAL;
+  Lstack, Rstack :ARRAY [1..max_stack] OF INTEGER;
+
+      (* --------------------------------------------------- *)
+      PROCEDURE CardQSortIndex( x :ARRAY OF CARDINAL; array_len :CARDINAL;
+                                VAR index :ARRAY OF CARDINAL );
+
+      VAR
+        median : CARDINAL;
+        i,j    : INTEGER;
+      BEGIN
+
+        n := VAL(INTEGER,array_len) - 1; (* back to zero offset *)
+
+        (* initialize the index *)
+        FOR i := 0 TO n DO
+          index[i] := VAL(CARDINAL,i);
+        END;
+
+        tos := 0;
+
+        L := 0;  R := n;
+
+        (* PUSH very first set *)
+        tos := tos + 1;  Lstack[tos] := L;  Rstack[tos] := R;
+
+        REPEAT
+
+          (* POP *)
+          L := Lstack[tos];  R := Rstack[tos];  tos := tos - 1;
+
+          IF R - L + 1 > n_small THEN
+
+            REPEAT
+              i := L;  j := R;    median := x[index[( L + R ) DIV 2]];
+
+              REPEAT
+                WHILE x[index[i]] < median DO
+                  i := i + 1;
+                END;
+                WHILE median < x[index[j]] DO
+                  j := j - 1;
+                END;
+
+                IF i <= j THEN (* swap *)
+                  ctemp := index[i];  index[i] := index[j];  index[j] := ctemp;
+                  i := i + 1;  j := j - 1;
+                END;
+              UNTIL i > j;
+
+              IF j - L < R - i THEN
+                IF i < R THEN (* PUSH *)
+                  tos := tos + 1;  Lstack[tos] := i;  Rstack[tos] := R;
+                END;
+                R := j;
+              ELSE
+                IF L < j THEN (* push *)
+                  tos := tos + 1;  Lstack[tos] := L;  Rstack[tos] := j;
+                END;
+                L := i;
+              END;
+
+            UNTIL L >= R;
+
+         ELSE
+
+           (* small sort for small number of values *)
+           FOR i := L TO R - 1 DO
+             FOR j := i TO R DO
+               IF x[index[i]] > x[index[j]] THEN
+                  ctemp    := index[i];
+                  index[i] := index[j];
+                  index[j] := ctemp
+               END;
+             END;
+           END;
+
+         END; (* check for small *)
+
+       UNTIL tos = 0;
+
+      END CardQSortIndex;
+
+      (* --------------------------------------------------- *)
+      PROCEDURE RealQSortIndex( x :ARRAY OF REAL; array_len :CARDINAL;
+                                VAR index :ARRAY OF CARDINAL );
+
+      VAR
+        median :REAL;
+        i,j    :INTEGER;
+      BEGIN
+
+        n := VAL(INTEGER,array_len) - 1; (* back to zero offset *)
+
+        (* initialize the index *)
+        FOR i := 0 TO n DO
+          index[i] := VAL(CARDINAL,i);
+        END;
+
+        tos := 0;
+
+        L := 0;  R := n;
+
+        (* PUSH very first set *)
+        tos := tos + 1;  Lstack[tos] := L;  Rstack[tos] := R;
+
+        REPEAT
+
+          (* POP *)
+          L := Lstack[tos];  R := Rstack[tos];  tos := tos - 1;
+
+          IF R - L + 1 > n_small THEN
+
+            REPEAT
+              i := L;  j := R;    median := x[index[( L + R ) DIV 2]];
+
+              REPEAT
+                WHILE x[index[i]] < median DO
+                  i := i + 1;
+                END;
+                WHILE median < x[index[j]] DO
+                  j := j - 1;
+                END;
+
+                IF i <= j THEN (* swap *)
+                  ctemp := index[i];  index[i] := index[j];  index[j] := ctemp;
+                  i := i + 1;  j := j - 1;
+                END;
+              UNTIL i > j;
+
+              IF j - L < R - i THEN
+                IF i < R THEN (* PUSH *)
+                  tos := tos + 1;  Lstack[tos] := i;  Rstack[tos] := R;
+                END;
+                R := j;
+              ELSE
+                IF L < j THEN (* push *)
+                  tos := tos + 1;  Lstack[tos] := L;  Rstack[tos] := j;
+                END;
+                L := i;
+              END;
+
+            UNTIL L >= R;
+
+         ELSE
+
+           (* small sort for small number of values *)
+           FOR i := L TO R - 1 DO
+             FOR j := i TO R DO
+               IF x[index[i]] > x[index[j]] THEN
+                  ctemp    := index[i];
+                  index[i] := index[j];
+                  index[j] := ctemp
+               END;
+             END;
+           END;
+
+         END; (* check for small *)
+
+       UNTIL tos = 0;
+
+      END RealQSortIndex;
+
+      (* --------------------------------------------------- *)
+      PROCEDURE CardQSort( VAR x :ARRAY OF CARDINAL; array_len :CARDINAL );
+
+      VAR
+        median : CARDINAL;
+        n,i,j  : INTEGER;
+      BEGIN
+
+        n := VAL(INTEGER,array_len) - 1; (* back to zero offset *)
+
+        tos := 0;
+
+        L := 0;  R := n;
+
+        (* PUSH very first set *)
+        tos := tos + 1;  Lstack[tos] := L;  Rstack[tos] := R;
+
+        REPEAT
+
+          (* POP *)
+          L := Lstack[tos];  R := Rstack[tos];  tos := tos - 1;
+
+          IF R - L + 1 > n_small THEN
+
+            REPEAT
+              i := L;  j := R;    median := x[( L + R ) DIV 2];
+
+              REPEAT
+                WHILE x[i] < median DO
+                  i := i + 1;
+                END;
+                WHILE median < x[j] DO
+                  j := j - 1;
+                END;
+
+                IF i <= j THEN (* swap *)
+                  ctemp := x[i];  x[i] := x[j];  x[j] := ctemp;
+                  i := i + 1;  j := j - 1;
+                END;
+              UNTIL i > j;
+
+              IF j - L < R - i THEN
+                IF i < R THEN (* PUSH *)
+                  tos := tos + 1;  Lstack[tos] := i;  Rstack[tos] := R;
+                END;
+                R := j;
+              ELSE
+                IF L < j THEN (* push *)
+                  tos := tos + 1;  Lstack[tos] := L;  Rstack[tos] := j;
+                END;
+                L := i;
+              END;
+
+            UNTIL L >= R;
+
+         ELSE
+
+           (* small sort for small number of values *)
+           FOR i := L TO R - 1 DO
+             FOR j := i TO R DO
+               IF x[i] > x[j] THEN
+                  ctemp := x[i];
+                  x[i]  := x[j];
+                  x[j]  := ctemp
+               END;
+             END;
+           END;
+
+         END; (* check for small *)
+
+       UNTIL tos = 0;
+
+      END CardQSort;
+
+      (* ----------------------------------------------------- *)
+      PROCEDURE CardBSort( VAR x :ARRAY OF CARDINAL; array_len :CARDINAL );
+      VAR i,j : INTEGER;
+      BEGIN
+        top    := 0;      (* open arrays are zero offset *)
+        bottom := VAL(INTEGER,array_len) - 1;
+
+        WHILE top < bottom DO
+
+          lastflip := top;
+
+          FOR i := top TO bottom-1 DO
+             IF x[i] > x[i+1] THEN    (* flip *)
+               ctemp  := x[i];
+               x[i]   := x[i+1];
+               x[i+1] := ctemp;
+               lastflip := i;
+             END;
+          END;
+
+          bottom := lastflip;
+
+          IF bottom > top THEN
+
+             i := bottom - 1;
+             FOR j := top TO bottom-1 DO
+               IF x[i] > x[i+1] THEN    (* flip *)
+                 ctemp  := x[i];
+                 x[i]   := x[i+1];
+                 x[i+1] := ctemp;
+                 lastflip := i;
+               END;
+               i := i - 1;
+             END;
+
+             top := lastflip + 1;
+
+          ELSE
+             (* force a loop failure *)
+             top := bottom + 1;
+          END;
+
+       END;
+
+      END CardBSort;
+
+
+      (* ----------------------------------------------------- *)
+      PROCEDURE RealBSort( VAR x :ARRAY OF REAL; array_len :CARDINAL );
+      VAR bottom,top : INTEGER;
+          i,j        : INTEGER;
+      BEGIN
+        top    := 0;      (* open arrays are zero offset *)
+        bottom := VAL(INTEGER,array_len) - 1;
+
+        WHILE top < bottom DO
+
+          lastflip := top;
+
+          FOR i := top TO bottom-1 DO
+             IF x[i] > x[i+1] THEN    (* flip *)
+               rtemp  := x[i];
+               x[i]   := x[i+1];
+               x[i+1] := rtemp;
+               lastflip := i;
+             END;
+          END;
+
+          bottom := lastflip;
+
+          IF bottom > top THEN
+
+             i := bottom - 1;
+             FOR j := top TO bottom-1 DO
+               IF x[i] > x[i+1] THEN    (* flip *)
+                 rtemp  := x[i];
+                 x[i]   := x[i+1];
+                 x[i+1] := rtemp;
+                 lastflip := i;
+               END;
+               i := i - 1;
+             END;
+
+             top := lastflip + 1;
+
+          ELSE
+             (* force a loop failure *)
+             top := bottom + 1;
+          END;
+
+       END;
+
+      END RealBSort;
+
+
+    (* ----------------------------------------------------- *)
+    PROCEDURE TopoSort( x, y :ARRAY OF CARDINAL; n_pairs :CARDINAL;
+                       VAR solution :ARRAY OF CARDINAL; VAR n_solution :CARDINAL;
+                       VAR error, sorted :BOOLEAN );
+    (*
+     This procedure needs some garbage collection added, i've tried but
+     will little success. J. Andrea, Dec.18/91
+    *)
+
+    TYPE
+      LPtr = POINTER TO Leader;
+      TPtr = POINTER TO Trailer;
+
+      Leader = RECORD
+                  key   :CARDINAL;
+                  count :INTEGER;
+                  trail :TPtr;
+                  next  :LPtr;
+               END;
+
+      Trailer = RECORD
+                  id   :LPtr;
+                  next :TPtr;
+                END;
+
+    VAR
+      p, q, head, tail :LPtr;
+      t                :TPtr;
+      i, max_solutions :CARDINAL;
+
+      (* -------------------------------------------- *)
+      PROCEDURE Find( w :CARDINAL ) :LPtr;
+      VAR h :LPtr;
+      BEGIN
+        h := head;   tail^.key := w;  (* sentinel *)
+        WHILE h^.key # w DO
+           h := h^.next;
+        END;
+        IF h = tail THEN
+          NEW( tail );
+          n := n + 1;
+          h^.count := 0;
+          h^.trail := NIL;
+          h^.next  := tail;
+        END;
+        RETURN h;
+      END Find;
+
+    BEGIN
+
+        error      := FALSE;
+        n_solution := 0;
+
+        IF n_pairs < 2 THEN
+          error := TRUE;
+        ELSE
+
+          max_solutions := HIGH( solution ) + 1;
+
+          NEW( head );  tail := head;  n := 0;
+
+          (* add all of the given pairs *)
+
+          FOR i := 0 TO n_pairs - 1 DO
+            p := Find( x[i] );   q := Find( y[i] );
+            NEW(t);
+            t^.id    := q;
+            t^.next  := p^.trail;
+            p^.trail := t;
+            q^.count := q^.count + 1;
+          END;
+
+          (* search for leaders without predecessors *)
+
+           p := head;  head := NIL;
+           WHILE p # tail DO
+            q := p;  p := q^.next;
+            IF q^.count = 0 THEN
+              (* insert q^ in new chain *)
+              q^.next := head;   head := q;
+            END;
+          END;
+
+          (* output phase *)
+
+          q := head;
+          WHILE ( NOT error ) & ( q # NIL ) DO
+            n_solution := n_solution + 1;
+            IF n_solution > max_solutions THEN
+              error := TRUE;
+            ELSE
+
+              solution[n_solution-1] := q^.key;
+              n := n - 1;
+              t := q^.trail;  q := q^.next;
+              WHILE t # NIL DO
+                p := t^.id;  p^.count := p^.count - 1;
+                IF p^.count = 0 THEN
+                  (* insert p^ in leader list *)
+                  p^.next := q;  q := p;
+                END;
+                t := t^.next;
+              END;
+            END;
+          END;
+
+          IF n # 0 THEN
+            sorted := FALSE;
+          ELSE
+            sorted := TRUE;
+          END;
+
+       END;
+
+    END TopoSort;
+
+BEGIN
+END Sorting.