Commit 52997eb9 authored by dnt's avatar dnt

[project @ 1996-11-26 14:38:44 by dnt]

Merged in changes from new-build-system branch
parent 3a3eec4c
#define IHaveSubdirs
SUBDIRS = hartel /* this is a whole bunch of progs */ \
ansi \
awards \
banner \
boyer \
boyer2 \
calendar \
cichelli \
clausify \
cse \
eliza \
expert \
fibheaps \
fft2 \
knights \
mandel \
mandel2 \
minimax \
multiplier \
pretty \
primetest \
rewrite \
scc \
simple \
sorting \
treejoin
/* life : it space-leaks and I am tired of it (WDP 95/05) */
/* SAVE: fft */
TOP = ../..
SUBDIRS = \
ansi awards banner boyer boyer2 calendar cichelli clausify cse \
eliza expert fibheaps fish fft2 hartel life knights mandel mandel2 \
minimax multiplier pretty primetest rewrite scc simple sorting treejoin
include $(TOP)/nofib/mk/nofib.mk
NoFibOneModuleCompileAndRun(ansi,)
TOP = ../../..
PROG = ansi
include $(TOP)/nofib/mk/nofib.mk
NoFibOneModuleCompileAndRun(awards,-o1 awards.stdout)
TOP = ../../..
PROG = awards
SRCS = QSort.hs Main.hs
include $(TOP)/nofib/mk/nofib.mk
{-
This module implements a sort function using a variation on
quicksort. It is stable, uses no concatenation and compares
only with <=.
sortLe sorts with a given predicate
sort uses the <= method
Author: Lennart Augustsson
-}
module QSort(sortLe, sort) where
sortLe :: (a -> a -> Bool) -> [a] -> [a]
sortLe le l = qsort le l []
sort :: (Ord a) => [a] -> [a]
sort l = qsort (<=) l []
-- qsort is stable and does not concatenate.
qsort le [] r = r
qsort le [x] r = x:r
qsort le (x:xs) r = qpart le x xs [] [] r
-- qpart partitions and sorts the sublists
qpart le x [] rlt rge r =
-- rlt and rge are in reverse order and must be sorted with an
-- anti-stable sorting
rqsort le rlt (x:rqsort le rge r)
qpart le x (y:ys) rlt rge r =
if le x y then
qpart le x ys rlt (y:rge) r
else
qpart le x ys (y:rlt) rge r
-- rqsort is as qsort but anti-stable, i.e. reverses equal elements
rqsort le [] r = r
rqsort le [x] r = x:r
rqsort le (x:xs) r = rqpart le x xs [] [] r
rqpart le x [] rle rgt r =
qsort le rle (x:qsort le rgt r)
rqpart le x (y:ys) rle rgt r =
if le y x then
rqpart le x ys (y:rle) rgt r
else
rqpart le x ys rle (y:rgt) r
NoFibOneModuleCompileAndRun(banner,-i banner.stdin)
TOP = ../../..
PROG = banner
include $(TOP)/nofib/mk/nofib.mk
SRCS_HS=Main.lhs
OBJS_O= Main.o
/* not multi-module, but a .lhs file... */
NoFibMultiModuleCompileAndRun(boyer,-o1 boyer.stdout)
NoFibHaskellCompile(boyer,Main,lhs)
......@@ -32,8 +32,6 @@ application of that function may be rewritten.
\begin{code}
module Main (main) where
--partain: import Prelude
import Prelude hiding (lookup) -- 1.3
data Term = Var Id |
Fun Id [Term] [Lemma]
......@@ -103,9 +101,9 @@ one_way_unify1 term1 term2@(Var vid2) subst
= if found
then (term1 == v2, subst)
else (True, (vid2,term1):subst)
where (found, v2) = lookup vid2 subst
where (found, v2) = find vid2 subst
{-
= case lookup vid2 subst of { (found, v2) ->
= case find vid2 subst of { (found, v2) ->
if found
then (term1 == v2, subst)
else (True, (vid2,term1):subst)
......@@ -124,11 +122,11 @@ one_way_unify1_lst (t1:ts1) (t2:ts2) subst
one_way_unify1_lst _ _ _ = (False, error "unify_lst")
lookup :: Id -> Substitution -> (Bool, Term)
lookup vid [] = (False, error "lookup")
lookup vid1 ((vid2,val2):bs) = if vid1 == vid2
find :: Id -> Substitution -> (Bool, Term)
find vid [] = (False, error "find")
find vid1 ((vid2,val2):bs) = if vid1 == vid2
then (True, val2)
else lookup vid1 bs
else find vid1 bs
\end{code}
\section{Variable substitution}
Once a substitution has been found which makes the LHS of a lemma
......@@ -142,7 +140,7 @@ arguments.
apply_subst :: Substitution -> Term -> Term
apply_subst subst term@(Var vid)
= if found then value else term
where (found, value) = lookup vid subst
where (found, value) = find vid subst
apply_subst subst (Fun f args ls)
= Fun f (map (apply_subst subst) args) ls
......
TOP = ../../..
PROG = boyer
SRCS = Main.lhs
include $(TOP)/nofib/mk/nofib.mk
SRCS_HS=Checker.hs Lisplikefns.hs Rewritefns.hs Rulebasetext.hs Main.hs
OBJS_O= Checker.o Lisplikefns.o Rewritefns.o Rulebasetext.o Main.o
NoFibMultiModuleCompileAndRun(boyer2,-o1 boyer2.stdout)
NoFibHaskellCompile(boyer2,Checker,hs)
NoFibHaskellCompile(boyer2,Lisplikefns,hs)
NoFibHaskellCompile(boyer2,Rewritefns,hs)
NoFibHaskellCompile(boyer2,Rulebasetext,hs)
NoFibHaskellCompile(boyer2,Main,hs)
......@@ -14,7 +14,7 @@ Haskell version::
-}
module Lisplikefns (
Token(..), Lisplist(..), LUT,
Token, Lisplist(..), LUT,
mkLisplist, strToToken, tv,
atom, car, cdr, cadr, caddr, cadddr, assoc,
newLUT, addtoLUT, getLUT
......
TOP = ../../..
PROG = boyer2
SRCS = Lisplikefns.hs Checker.hs Rewritefns.hs Rulebasetext.hs Main.hs
include $(TOP)/nofib/mk/nofib.mk
NoFibOneModuleCompileAndRun(calendar,1993)
TOP = ../../..
PROG = calendar
EXTRA_RUNTESTFLAGS = 1993
include $(TOP)/nofib/mk/nofib.mk
SRCS_HS=Main.hs Prog.hs Aux.hs Key.lhs Interval.hs
OBJS_O= Main.o Prog.o Aux.o Key.o Interval.o
NoFibMultiModuleCompileAndRun(cichelli,-o1 cichelli.stdout)
NoFibHaskellCompile(cichelli,Main,hs)
NoFibHaskellCompile(cichelli,Prog,hs)
NoFibHaskellCompile(cichelli,Aux,hs)
NoFibHaskellCompile(cichelli,Key,lhs)
NoFibHaskellCompile(cichelli,Interval,hs)
NoFibDependTarget(cichelli, $(SRCS_HS))
TOP = ../../..
PROG = cichelli
SRCS = Key.lhs Aux.hs Interval.hs Prog.hs Main.hs
include $(TOP)/nofib/mk/nofib.mk
NoFibOneModuleCompileAndRun(clausify,)
TOP = ../../..
PROG = clausify
include $(TOP)/nofib/mk/nofib.mk
SRCS_HS=StateMonad.hs Main.hs
OBJS_O= StateMonad.o Main.o
NoFibMultiModuleCompileAndRun(cse,-o1 cse.stdout)
NoFibHaskellCompile(cse,StateMonad,hs)
NoFibHaskellCompile(cse,Main,hs)
NoFibDependTarget(cse, $(SRCS_HS))
......@@ -72,13 +72,20 @@ visited n = fetch `bind` \us ->
findCommon :: Eq a => LabGraph a -> LabGraph a
findCommon = snd . foldr sim (id,[])
where sim (n,s,cs) (r,lg)
| null ms = (r, [(n,s,rcs)]++lg)
| otherwise = ((n +=> head ms) r, lg)
where ms = [m | (m,s',cs')<-lg, s==s', cs'==rcs]
rcs = map r cs
(+=>) :: Eq a => a -> b -> (a -> b) -> (a -> b)
where
sim ::
Eq a => (Label,a,[Label]) -> (Label -> Label, LabGraph a) ->
(Label -> Label, LabGraph a)
sim (n,s,cs) (r,lg) =
if null ms then
(r, [(n,s,rcs)] ++ lg)
else
((n +=> head ms) r, lg)
where
ms = [m | (m,s',cs')<-lg, s==s', cs'==rcs]
rcs = map r cs
(+=>) :: Eq a => a -> b -> (a -> b) -> (a -> b)
(+=>) x fx f y = if x==y then fx else f y
-- Common subexpression elimination: -----------------------------------------
......
TOP = ../../..
PROG = cse
SRCS = StateMonad.hs Main.hs
include $(TOP)/nofib/mk/nofib.mk
NoFibOneModuleCompileAndRun(eliza,-i eliza.stdin)
TOP = ../../..
PROG = eliza
include $(TOP)/nofib/mk/nofib.mk
SRCS_HS=Result.hs Table.hs Knowledge.hs Match.hs Search.hs Main.hs
OBJS_O= Result.o Table.o Knowledge.o Match.o Search.o Main.o
NoFibMultiModuleCompileAndRun(expert,-i expert.stdin -o1 expert.stdout)
NoFibHaskellCompile(expert,Result,hs)
NoFibHaskellCompile(expert,Table,hs)
NoFibHaskellCompile(expert,Knowledge,hs)
NoFibHaskellCompile(expert,Match,hs)
NoFibHaskellCompile(expert,Search,hs)
NoFibHaskellCompile(expert,Main,hs)
NoFibDependTarget(expert, $(SRCS_HS))
TOP = ../../..
PROG = expert
SRCS = Result.hs Table.hs Knowledge.hs Match.hs Search.hs Main.hs
include $(TOP)/nofib/mk/nofib.mk
interface Fast2haskell where
abortstr :: [Char] -> [Response] -> [Request] {-# ARITY _ = 2 #-}
delay :: a -> [Response] -> [Request] {-# ARITY _ = 1 #-}
descr :: a -> b -> (a, b) {-# ARITY _ = 2 #-}
destr_update :: Ix a => Array a b -> a -> b -> Array a b {-# ARITY _ = 4 #-}
entier :: (Num b, RealFrac a) => a -> b {-# ARITY _ = 3 #-}
fix :: (a -> a) -> a {-# ARITY _ = 1 #-}
force :: a -> a {-# ARITY _ = 1 #-}
iff :: Bool -> a -> a -> a {-# ARITY _ = 3 #-}
iffrev :: a -> a -> Bool -> a {-# ARITY _ = 3 #-}
indassoc :: Assoc b a -> b {-# ARITY _ = 1 #-}
land_i :: Int -> Int -> Int {-# ARITY _ = 2 #-}
lnot_i :: Int -> Int {-# ARITY _ = 1 #-}
lor_i :: Int -> Int -> Int {-# ARITY _ = 2 #-}
lowbound :: (b, a) -> b {-# ARITY _ = 1 #-}
lshift_i :: Int -> Int -> Int {-# ARITY _ = 2 #-}
pair :: [a] -> Bool {-# ARITY _ = 1 #-}
rshift_i :: Int -> Int -> Int {-# ARITY _ = 2 #-}
seq :: a -> b -> b {-# ARITY _ = 2 #-}
strcmp :: [Char] -> [Char] -> Bool {-# ARITY _ = 2 #-}
tabulate :: (Enum a, Ix a) => (a -> b) -> (a, a) -> Array a b {-# ARITY _ = 4 #-}
upbound :: (a, b) -> b {-# ARITY _ = 1 #-}
update :: Ix a => Array a b -> a -> b -> Array a b {-# ARITY _ = 4 #-}
valassoc :: Assoc a b -> b {-# ARITY _ = 1 #-}
type Array_type a = Array Int a
type Assoc_type a = Assoc Int a
type Complex_type = Complex Double
type Descr_type = (Int, Int)
interface Word where
infixl 7 `bitAnd`
infixl 8 `bitLsh`
infixl 5 `bitOr`
infixl 8 `bitRsh`
infixl 6 `bitXor`
byteToInt :: Byte -> Int {-# ARITY _ = 1 #-}
shortToInt :: Short -> Int {-# ARITY _ = 1 #-}
wordToInt :: Word -> Int {-# ARITY _ = 1 #-}
class Bits a where
bitAnd :: a -> a -> a
bitOr :: a -> a -> a
bitXor :: a -> a -> a
bitCompl :: a -> a
bitRsh :: a -> Int -> a
bitLsh :: a -> Int -> a
bitSwap :: a -> a
bit0 :: a
bitSize :: a -> Int
data Byte
data Short
data Word
instance Eq Byte
instance Eq Short
instance Eq Word
instance Num Word
instance Ord Byte
instance Ord Short
instance Ord Word
instance Text Word
instance Bits Word
> module Complex_Vectors
> (ComplexF(..), rootsOfUnity,thetas, norm,distance)
> (ComplexF, rootsOfUnity,thetas, norm,distance)
> where
> import Complex --
......
SRCS_LHS= Complex_Vectors.lhs Fourier.lhs Main.lhs
OBJS_O = Complex_Vectors.o Fourier.o Main.o
NoFibMultiModuleCompileAndRun(fft2,-o1 fft2.stdout)
NoFibHaskellCompile(fft2,Complex_Vectors,lhs)
NoFibHaskellCompile(fft2,Fourier,lhs)
NoFibHaskellCompile(fft2,Main,lhs)
NoFibDependTarget(fft2, $(SRCS_LHS))
TOP = ../../..
PROG = fft2
SRCS = Complex_Vectors.lhs Fourier.lhs Main.lhs
include $(TOP)/nofib/mk/nofib.mk
SRCS_HS=Main.lhs
OBJS_O= Main.o
/* not multi-module, but a .lhs file... */
NoFibMultiModuleCompileAndRun(fibheaps, 5000 -o1 fibheaps.stdout)
NoFibHaskellCompile(fibheaps,Main,lhs)
......@@ -53,12 +53,6 @@ first understand binomial queues. See, for example, David King's
>import PreludeGlaST
>import Array
>import System
>#define thenST_ seqST
>#define sequenceST listST
>#define newArr newArray
>#define readArr readArray
>#define writeArr writeArray
>type Assoc a b = (a,b)
--------------------
......@@ -85,9 +79,8 @@ It will also be useful to extract the minimum element from a tree.
>root (Node x _) = x
We will frequently need to tag trees with their degrees.
We use Assoc instead of simple pairs for compatibility with accumArray.
>type TaggedTree a = Assoc Int (Tree a)
>type TaggedTree a = (Int,Tree a)
>
>degree (k, t) = k
>tree (k, t) = t
......@@ -117,8 +110,8 @@ is irrelevant.
>
>applyToAll :: (a -> ST s ()) -> Bag a -> ST s ()
>applyToAll f EmptyBag = returnST ()
>applyToAll f (ConsBag x b) = f x `thenST_` applyToAll f b
>applyToAll f (UnionBags b1 b2) = applyToAll f b1 `thenST_` applyToAll f b2
>applyToAll f (ConsBag x b) = f x `seqST` applyToAll f b
>applyToAll f (UnionBags b1 b2) = applyToAll f b1 `seqST` applyToAll f b2
--------------------
......@@ -197,10 +190,10 @@ In the first implementation, there are three steps.
> d = log2 (n-1) -- maximum possible degree
>
> ins a (i, t) =
> readArr a i `thenST` \e ->
> readArray a i `thenST` \e ->
> case e of
> Zero -> writeArr a i (One t)
> One t2 -> writeArr a i Zero `thenST_`
> Zero -> writeArray a i (One t)
> One t2 -> writeArray a i Zero `seqST`
> ins a (i+1, link t t2)
Note that after inserting all the trees, the array contains trees
......@@ -209,7 +202,7 @@ highest order bit of n-1 is one, we know that there is a tree in
the highest slot of the array.
> getMin a =
> readArr a d `thenST` \e ->
> readArray a d `thenST` \e ->
> case e of
> Zero -> error "must be One" -- since array is filled as bits of n-1
> One t -> getMin' a d t EmptyBag 0
......@@ -217,7 +210,7 @@ the highest slot of the array.
> if i >= d then
> returnST ((mini, mint),b)
> else
> readArr a i `thenST` \e ->
> readArray a i `thenST` \e ->
> case e of
> Zero -> getMin' a mini mint b (i+1)
> One t -> if root mint <= root t then
......@@ -226,9 +219,9 @@ the highest slot of the array.
> getMin' a i t (ConsBag (mini, mint) b) (i+1)
>
> in
> runST (newArr (0,d) Zero `thenST` \a ->
> applyToAll (ins a) f `thenST_`
> sequenceST (map (ins a) (getChildren tt)) `thenST_`
> runST (newArray (0,d) Zero `thenST` \a ->
> applyToAll (ins a) f `seqST`
> listST (map (ins a) (getChildren tt)) `seqST`
> getMin a `thenST` \ (tt,f) ->
> returnST (FH (n-1) tt f))
......
TOP = ../../..
PROG = fibheaps
SRCS = Main.lhs
EXTRA_RUNTESTFLAGS = 5000
include $(TOP)/nofib/mk/nofib.mk
interface Fish_lines where {
{-# IMPORTING Vector #-}
p_tile :: [(Int, Int, Int, Int)] {-# ARITY p_tile = 0 #-}{-# STRICTNESS p_tile = "T,T" ST #-};
q_tile :: [(Int, Int, Int, Int)] {-# ARITY q_tile = 0 #-}{-# STRICTNESS q_tile = "T,T" ST #-};
r_tile :: [(Int, Int, Int, Int)] {-# ARITY r_tile = 0 #-}{-# STRICTNESS r_tile = "T,T" ST #-};
s_tile :: [(Int, Int, Int, Int)] {-# ARITY s_tile = 0 #-}{-# STRICTNESS s_tile = "T,T" ST #-}
}
interface Fun_geom where {
{-# IMPORTING Fish_lines #-}
import Vector(Nr);
grid :: Int -> Int -> [(Nr, Nr, Nr, Nr)] -> (Nr, Nr) -> (Nr, Nr) -> (Nr, Nr) -> [(Nr, Nr, Nr, Nr)] {-# ARITY grid = 6 #-}{-# STRICTNESS grid = "2,F" ST #-};
nil :: a -> b -> c -> [d] {-# ARITY nil = 3 #-}{-# STRICTNESS nil = "T,T" ST #-};
rot :: ((Nr, Nr) -> a -> (Nr, Nr) -> b) -> (Nr, Nr) -> (Nr, Nr) -> a -> b {-# ARITY rot = 4 #-}{-# STRICTNESS rot = "T,F" ST #-};
beside :: Int -> Int -> ((Nr, Nr) -> (Int, Int) -> a -> [b]) -> ((Nr, Nr) -> (Int, Int) -> a -> [b]) -> (Nr, Nr) -> (Int, Int) -> a -> [b] {-# ARITY beside = 7 #-}{-# STRICTNESS beside = "T,F" ST #-};
above :: Int -> Int -> ((Nr, Nr) -> a -> (Int, Int) -> [b]) -> ((Nr, Nr) -> a -> (Int, Int) -> [b]) -> (Nr, Nr) -> a -> (Int, Int) -> [b] {-# ARITY above = 7 #-}{-# STRICTNESS above = "T,F" ST #-};
squarelimit :: (Nr, Nr) -> (Int, Int) -> (Int, Int) -> [(Nr, Nr, Nr, Nr)] {-# ARITY squarelimit = 0 #-}{-# STRICTNESS squarelimit = "T,F" ST #-}
}
SRCS_HS = Fish_lines.hs Fun_geom.hs Main.hs Vector.hs
OBJS_O = Fish_lines.o Fun_geom.o Main.o Vector.o
NoFibMultiModuleCompileAndRun(fish,-o1 fish.stdout)
NoFibHaskellCompile(fish,Fish_lines,hs)
NoFibHaskellCompile(fish,Fun_geom,hs)
NoFibHaskellCompile(fish,Main,hs)
NoFibHaskellCompile(fish,Vector,hs)
NoFibDependTarget(fish, $(SRCS_HS))
module Main
where
import Vector
import Fun_geom
--import AttrModule
--import Xview_Interface
run :: [(Int,Int,Int,Int)]
run = squarelimit (0, 0) (640, 0) (0,640)
-- partain: avoid X11
main = putStr (shows run "\n")
{-
roundrun = [Draw_line a b c d | (a, b, c, d) <- run]
main i
= [Echo False,
ReadChan stdin,
AppendChan stderr "Fish in Haskell\n",
AppendChan stdout (prg i)]
prg i = unlines (map shw (prog i))
prog ~(_ : ~(~(Str x) : (Success : rest)))
= [Xv_create 0 FRAME [],
Xv_create base_win PANEL [],
Xv_create panel_win PANEL_BUTTON [PANEL_LABEL_STRING "Start Fish"],
Window_fit_height panel_win,
Xv_create base_win CANVAS [],
Window_fit canvas_win,
Xv_main_loop base_win
] ++ others (drop 3 rep) 1
where
rep = (map read (lines x))::[Xview_reply]
WinRef base_win = rep!!0
WinRef panel_win = rep!!1
WinRef canvas_win = rep!!2
others ~(x:xs) i
= if (x == PanelEvent 3) then
roundrun ++ Return:others xs (i+1)
else
[Draw_line 0 i 500 i,Return] ++ others xs (i+2)
-}
module Main (main) where
-- A vector is a pair of floats
type Vec = (Int, Int)
-- This adds two vectors.
vec_add :: Vec -> Vec -> Vec
(x1,y1) `vec_add` (x2,y2) = (x1+x2, y1+y2)
-- This substracts the second vector from the first.
vec_sub :: Vec -> Vec -> Vec
(x1,y1) `vec_sub` (x2,y2) = (x1-x2, y1-y2)
-- This function is provided for efficiency. The first argument is vector.
-- The second argument and third arguments are integers. These integers
-- represent the nummerator and denominator of a rational number which
-- is used to scale the given vector.
scale_vec2 :: Vec -> Int -> Int -> Vec
scale_vec2 (x,y) a b = ((x*a) `div` b, (y*a) `div` b)
p_tile :: [(Int,Int,Int,Int)]
q_tile :: [(Int,Int,Int,Int)]
r_tile :: [(Int,Int,Int,Int)]
s_tile :: [(Int,Int,Int,Int)]
p_tile =
[(0,3,3,4), (3,4,0,8), (0,8,0,3), (6,0,4,4), (4,5,4,10),
(4,10,7,6), (7,6,4,5), (11,0,10,4), (10,4,9,6), (9,6,8,8), (8,8,4,13),
(4,13,0,16), (0,16,6,15), (6,15,8,16), (8,16,12,12), (12,12,16,12),
(10,16,12,14), (12,14,16,13), (12,16,13,15), (13,15,16,14), (14,16,16,15),
(8,12,16,10), (8,8,12,9), (12,9,16,8), (9,6,12,7), (12,7,16,6),
(10,4,13,5), (13,5,16,4), (11,0,14,2), (14,2,16,2)]
q_tile =
[(0,8,4,7), (4,7,6,7), (6,7,8,8), (8,8,12,10), (12,10,16,16),
(0,12,3,13), (3,13,5,14), (5,14,7,15), (7,15,8,16), (2,16,3,13),
(4,16,5,14), (6,16,7,15), (0,10,7,11), (9,13,8,15), (8,15,11,15),
(11,15,9,13), (10,10,8,12), (8,12,12,12), (12,12,10,10), (2,0,4,5),
(4,5,4,7), (4,0,6,5), (6,5,6,7), (6,0,8,5), (8,5,8,8), (10,0,14,11),
(12,0,13,4), (13,4,16,8), (16,8,15,10), (15,10,16,16), (13,0,16,6),
(14,0,16,4), (15,0,16,2), (0,0,8,0), (12,0,16,0), (0,0,0,8), (0,12,0,16)]
r_tile =
[(0,0,8,8), (12,12,16,16), (0,4,5,10), (0,8,2,12), (0,12,1,14),
(16,6,11,10), (11,10,6,16), (16,4,14,6), (14,6,8,8), (8,8,5,10),
(5,10,2,12), (2,12,0,16), (16,8,12,12), (12,12,11,16), (1,1,4,0),
(2,2,8,0), (3,3,8,2), (8,2,12,0), (5,5,12,3), (12,3,16,0), (11,16,12,12),
(12,12,16,8), (13,13,16,10), (14,14,16,12), (15,15,16,14)]
s_tile =
[(0,0,4,2), (4,2,8,2), (8,2,16,0), (0,4,2,1), (0,6,7,4),
(0,8,8,6), (0,10,7,8), (0,12,7,10), (0,14,7,13), (13,13,16,14),
(14,11,16,12), (15,9,16,10), (16,0,10,4), (10,4,8,6), (8,6,7,8),
(7,8,7,13), (7,13,8,16), (12,16,13,13), (13,13,14,11), (14,11,15,9),
(15,9,16,8), (10,16,11,10), (12,4,10,6), (10,6,12,7), (12,7,12,4),
(15,5,13,7), (13,7,15,8), (15,8,15,5)]
type Line_segment = (Int, Int, Int, Int)
type Picture = Vec -> Vec -> Vec -> [Line_segment]
nil a b c = []
grid :: Int -> Int -> [Line_segment] -> Vec -> Vec -> Vec -> [Line_segment]
grid m n segments a b c
= [tup2
(a `vec_add` (scale_vec2 b x0 m) `vec_add` (scale_vec2 c y0 n))
(a `vec_add` (scale_vec2 b x1 m) `vec_add` (scale_vec2 c y1 n))
| (x0, y0, x1, y1) <- segments]
rot p a b c = p (a `vec_add` b) c ((0, 0) `vec_sub` b)
beside m n p q a b c
= p a (scale_vec2 b m (m+n)) c ++
q (a `vec_add` (scale_vec2 b m (m+n))) (scale_vec2 b n (n+m)) c
above m n p q a b c
= p (a `vec_add` (scale_vec2 c n (m+n))) b (scale_vec2 c m (n+m)) ++
q a b (scale_vec2 c n (m+n))
tup2 :: (a, b) -> (c, d) -> (a, b, c, d)
tup2 (a, b) (c, d) = (a, b, c, d)
tile_to_grid = grid 16 16
p = tile_to_grid p_tile
q = tile_to_grid q_tile
r = tile_to_grid r_tile
s = tile_to_grid s_tile
quartet a b c d = above 1 1 (beside 1 1 a b) (beside 1 1 c d)
t = quartet p q r s
cycle' p1 = quartet p1 (rot (rot (rot p1))) (rot p1) (rot (rot p1))
u = cycle' (rot q)
side1 = quartet nil nil (rot t) t
side2 = quartet side1 side1 (rot t) t
corner1 = quartet nil nil nil u
corner2 = quartet corner1 side1 (rot side1) u
pseudocorner = quartet corner2 side2 (rot side2) (rot t)
pseudolimit = cycle' pseudocorner
nonet p1 p2 p3 p4 p5 p6 p7 p8 p9
= above 1 2 (beside 1 2 p1 (beside 1 1 p2 p3))
(above 1 1 (beside 1 2 p4 (beside 1 1 p5 p6))
(beside 1 2 p7 (beside 1 1 p8 p9)))
corner = nonet corner2 side2 side2 (rot side2) u (rot t) (rot side2) (rot t)