module Main (main) where

main :: IO ()
main = do print $ f True
          print $ g 3
          print $ h 'a'

f :: a -> a
f x = x

g :: Int -> Int
g x = x

h :: Char -> Char
Just h = Just id


module Main (main) where

import Data.Array.Unboxed
import System.Environment

main :: IO ()
main = print (yan 30 + yan 40)

{- we're looking for:
MAIN        MAIN                    106           0    0.0    0.0     0.0  100.0
 CAF        Main                    211           0    0.0    0.0     0.0   99.1
  yan       Main                    213           2    0.0    0.0     0.0   98.9
   yan.e    Main                    217           1    0.0    0.0     0.0   98.9
    big     Main                    218           1    0.0   98.9     0.0   98.9
  main      Main                    212           1    0.0    0.2     0.0    0.2
   yan      Main                    214           0    0.0    0.0     0.0    0.0
    yan.\   Main                    215           2    0.0    0.0     0.0    0.0
     yan1   Main                    216           2    0.0    0.0     0.0    0.0

Note the 2 entries for yan.\, the lambda expression inside yan.
-}

big :: Int -> Int
big x = (array (0,1000000) [(0,x)] :: UArray Int Int) ! 0

yan = let e = big 20 in \x -> {-# SCC yan1 #-} x + e


{-# LANGUAGE BangPatterns #-}
main = print (f 20 30)

{-# NOINLINE f #-}
f x = let !x' = fib x in \y -> x' + fib y

fib :: Int -> Int
fib n = if n < 2 then 1 else fib (n-1) + fib (n-2)


f :: Int -> Int -> Int
{-# NOINLINE f #-}
f x _ = x

g :: Int -> Int -> Int
{-# NOINLINE g #-}
g x = f (1+1) -- slightly non-trivial so it will float

main :: IO Int
main = return $! g 3 5


-- Original test case for #11627 (space_leak_001.hs)

import Data.List

main :: IO ()
main = print $ length $ show (foldl' (*) 1 [1..100000] :: Integer)


{-# LANGUAGE MagicHash     #-}
{-# LANGUAGE UnboxedTuples #-}

-- A reduced test case for #11627

import GHC.Prim
import GHC.Types (Int(..),IO(..))
import System.Mem

main :: IO ()
main = do
    -- Allocate a large object (size >= 8/10 of one block = 8/10 * 4096 B)
    let nBytes = 123 * 4096
    b <- newBlob nBytes

    -- Shrink it by at least one word
    let delta = 100
    shrinkBlob b $ nBytes - delta

    -- Perform a heap census (assumes we are running with -i0, so a census is
    -- run after every GC)
    performGC

    -- Hold on to b so it is not GCed before the census
    shrinkBlob b $ nBytes - delta

------------------------------------------------------------------------------

data Blob = Blob# !(MutableByteArray# RealWorld)

newBlob :: Int -> IO Blob
newBlob (I# n#) =
    IO $ \s -> case newByteArray# n# s of
                   (# s', mba# #) -> (# s', Blob# mba# #)

shrinkBlob :: Blob -> Int -> IO ()
shrinkBlob (Blob# mba#) (I# n#) =
    IO $ \s -> case shrinkMutableByteArray# mba# n# s of
                   s' -> (# s', () #)


{-# OPTIONS_GHC -fprof-auto-top #-}

-- We want to make sure that 'foo' gets a cost center
-- automatically even though it is INLINABLE. INLINE functions
-- do not get cost centers automatically.

import Data.List (zipWith3)
import Control.Exception (evaluate)

{-# INLINABLE foo #-}
foo :: Num a => a -> a -> a -> a
foo a b c = a * b + c

{-# NOINLINE niz3 #-}
niz3 :: (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
niz3 x y z = zipWith3 x y z

blah :: [Int]
blah = replicate 100 1

main = evaluate $ sum $ niz3 foo blah blah blah


{-# LANGUAGE ScopedTypeVariables #-}
module Main where

eval :: forall a b. (a -> b -> b) -> b -> [a] -> b
eval f b xs = load xs []
  where
    load :: [a] -> [a] -> b
    load [] stk          = unload b stk
    load (x:xs) stk      = load xs (x : stk)

    unload :: b -> [a] -> b
    unload  v []         = v
    unload  v (x  : stk) = unload ((f $! x) $! v) stk

main :: IO ()
main = print (eval (||) False (True : replicate 10000000 False))


import Control.Monad
import Data.IORef
import System.Environment

main = do
    [n] <- getArgs
    replicateM (read n) (newIORef [1,2,3])


fib1 n = fib1' n
  where
    fib1' n = {-# SCC "nfib'" #-} nfib n -- %time: 0 (both individual and inherited)
      where
        nfib n = if n < 2 then 1 else nfib (n-1) + nfib (n-2)

fib2 n = fib2' n
fib2' n = nfib n -- %time: 100 (both individual and inherited)
  where
    nfib n = if n < 2 then 1 else nfib (n-1) + nfib (n-2)

fib3 = fib3'
fib3' n = nfib n -- %time: 100 (both individual and inherited)
  where
    nfib n = if n < 2 then 1 else nfib (n-1) + nfib (n-2)

main = do
  print (fib1 28)
  print (fib2 28)
  print (fib3 28)


main = let xs = [1..] in print (length (xs ++ xs))


-- A second test for trac #3001, which segfaults when compiled by
-- GHC 6.10.1 and run with +RTS -hb. Most of the code is from the
-- binary 0.4.4 package.

{-# LANGUAGE CPP, FlexibleInstances, FlexibleContexts, MagicHash #-}

module Main (main) where

import Data.Semigroup

import Data.ByteString.Internal (inlinePerformIO)

import qualified Data.ByteString      as S
import qualified Data.ByteString.Internal      as S
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.Lazy.Internal as L

import GHC.Exts
import GHC.Word

import Control.Monad
import Foreign
import System.IO.Unsafe
import System.IO

import Data.Char    (chr,ord)

import Control.Applicative

main :: IO ()
main = do
  encodeFile "test.bin" $ replicate 10000 'x'
  print =<< (decodeFile "test.bin" :: IO String)

class Binary t where
    put :: t -> Put
    get :: Get t

encodeFile :: Binary a => FilePath -> a -> IO ()
encodeFile f v = L.writeFile f $ runPut $ put v

decodeFile :: Binary a => FilePath -> IO a
decodeFile f = do
    s <- L.readFile f
    return $ runGet (do v <- get
                        m <- isEmpty
                        m `seq` return v) s

instance Binary Word8 where
    put     = putWord8
    get     = getWord8

instance Binary Word32 where
    put     = putWord32be
    get     = getWord32be

instance Binary Int32 where
    put i   = put (fromIntegral i :: Word32)
    get     = liftM fromIntegral (get :: Get Word32)

instance Binary Int where
    put i   = put (fromIntegral i :: Int32)
    get     = liftM fromIntegral (get :: Get Int32)

instance Binary Char where
    put a = put (ord a)
    get = do w <- get
             return $! chr w

instance Binary a => Binary [a] where
    put l  = put (length l) >> mapM_ put l
    get    = do n <- get
                replicateM n get

data PairS a = PairS a !Builder

sndS :: PairS a -> Builder
sndS (PairS _ b) = b

newtype PutM a = Put { unPut :: PairS a }

type Put = PutM ()

instance Functor PutM where
        fmap f m = Put $ let PairS a w = unPut m in PairS (f a) w

instance Monad PutM where
    return a = Put $ PairS a mempty

    m >>= k  = Put $
        let PairS a w  = unPut m
            PairS b w' = unPut (k a)
        in PairS b (w `mappend` w')

    m >> k  = Put $
        let PairS _ w  = unPut m
            PairS b w' = unPut k
        in PairS b (w `mappend` w')

instance Applicative PutM where
    pure  = return
    (<*>) = ap

tell :: Builder -> Put
tell b = Put $ PairS () b

runPut :: Put -> L.ByteString
runPut = toLazyByteString . sndS . unPut

putWord8            :: Word8 -> Put
putWord8            = tell . singletonB

putWord32be         :: Word32 -> Put
putWord32be         = tell . putWord32beB

-----

newtype Get a = Get { unGet :: S -> (a, S) }

data S = S {-# UNPACK #-} !S.ByteString  -- current chunk
           L.ByteString                  -- the rest of the input
           {-# UNPACK #-} !Int64         -- bytes read

runGet :: Get a -> L.ByteString -> a
runGet m str = case unGet m (initState str) of (a, _) -> a

isEmpty :: Get Bool
isEmpty = do
    S s ss _ <- getZ
    return (S.null s && L.null ss)

initState :: L.ByteString -> S
initState xs = mkState xs 0

getWord32be :: Get Word32
getWord32be = do
    s <- readN 4 id
    return $! (fromIntegral (s `S.index` 0) `shiftl_w32` 24) .|.
              (fromIntegral (s `S.index` 1) `shiftl_w32` 16) .|.
              (fromIntegral (s `S.index` 2) `shiftl_w32`  8) .|.
              (fromIntegral (s `S.index` 3) )

getWord8 :: Get Word8
getWord8 = getPtr (sizeOf (undefined :: Word8))

mkState :: L.ByteString -> Int64 -> S
mkState l = case l of
    L.Empty      -> S S.empty L.empty
    L.Chunk x xs -> S x xs

readN :: Int -> (S.ByteString -> a) -> Get a
readN n f = fmap f $ getBytes n

shiftl_w32 :: Word32 -> Int -> Word32
shiftl_w32 (W32# w) (I# i) = W32# (w `uncheckedShiftL#`   i)

getPtr :: Storable a => Int -> Get a
getPtr n = do
    (fp,o,_) <- readN n S.toForeignPtr
    return . S.inlinePerformIO $ withForeignPtr fp $ \p -> peek (castPtr $ p `plusPtr` o)

getBytes :: Int -> Get S.ByteString
getBytes n = do
    S s ss bytes <- getZ
    if n <= S.length s
        then do let (consume,rest) = S.splitAt n s
                putZ $! S rest ss (bytes + fromIntegral n)
                return $! consume
        else
              case L.splitAt (fromIntegral n) (s `joinZ` ss) of
                (consuming, rest) ->
                    do let now = S.concat . L.toChunks $ consuming
                       putZ $! mkState rest (bytes + fromIntegral n)
                       -- forces the next chunk before this one is returned
                       if (S.length now < n)
                         then
                            fail "too few bytes"
                         else
                            return now

joinZ :: S.ByteString -> L.ByteString -> L.ByteString
joinZ bb lb
    | S.null bb = lb
    | otherwise = L.Chunk bb lb

instance Monad Get where
    return a  = Get (\s -> (a, s))
    {-# INLINE return #-}

    m >>= k   = Get (\s -> let (a, s') = unGet m s
                           in unGet (k a) s')
    {-# INLINE (>>=) #-}

    fail      = error "failDesc"

instance Applicative Get where
    pure  = return
    (<*>) = ap

getZ :: Get S
getZ   = Get (\s -> (s, s))

putZ :: S -> Get ()
putZ s = Get (\_ -> ((), s))

instance Functor Get where
    fmap f m = Get (\s -> case unGet m s of
                             (a, s') -> (f a, s'))

-----

singletonB :: Word8 -> Builder
singletonB = writeN 1 . flip poke

writeN :: Int -> (Ptr Word8 -> IO ()) -> Builder
writeN n f = ensureFree n `append` unsafeLiftIO (writeNBuffer n f)

unsafeLiftIO :: (Buffer -> IO Buffer) -> Builder
unsafeLiftIO f =  Builder $ \ k buf -> inlinePerformIO $ do
    buf' <- f buf
    return (k buf')

append :: Builder -> Builder -> Builder
append (Builder f) (Builder g) = Builder (f . g)

writeNBuffer :: Int -> (Ptr Word8 -> IO ()) -> Buffer -> IO Buffer
writeNBuffer n f (Buffer fp o u l) = do
    withForeignPtr fp (\p -> f (p `plusPtr` (o+u)))
    return (Buffer fp o (u+n) (l-n))

newtype Builder = Builder {
        -- Invariant (from Data.ByteString.Lazy):
        --      The lists include no null ByteStrings.
        runBuilder :: (Buffer -> [S.ByteString]) -> Buffer -> [S.ByteString]
    }

data Buffer = Buffer {-# UNPACK #-} !(ForeignPtr Word8)
                     {-# UNPACK #-} !Int                -- offset
                     {-# UNPACK #-} !Int                -- used bytes
                     {-# UNPACK #-} !Int                -- length left

toLazyByteString :: Builder -> L.ByteString
toLazyByteString m = L.fromChunks $ unsafePerformIO $ do
    buf <- newBuffer defaultSize
    return (runBuilder (m `append` flush) (const []) buf)

ensureFree :: Int -> Builder
ensureFree n = n `seq` withSize $ \ l ->
    if n <= l then emptyBuilder else
        flush `append` unsafeLiftIO (const (newBuffer (max n defaultSize)))

withSize :: (Int -> Builder) -> Builder
withSize f = Builder $ \ k buf@(Buffer _ _ _ l) ->
    runBuilder (f l) k buf

defaultSize :: Int
defaultSize = 32 * k - overhead
    where k = 1024
          overhead = 2 * sizeOf (undefined :: Int)

newBuffer :: Int -> IO Buffer
newBuffer size = do
    fp <- S.mallocByteString size
    return $! Buffer fp 0 0 size

putWord32beB :: Word32 -> Builder
putWord32beB w = writeN 4 $ \p -> do
    poke p               (fromIntegral (shiftr_w32 w 24) :: Word8)
    poke (p `plusPtr` 1) (fromIntegral (shiftr_w32 w 16) :: Word8)
    poke (p `plusPtr` 2) (fromIntegral (shiftr_w32 w  8) :: Word8)
    poke (p `plusPtr` 3) (fromIntegral (w)               :: Word8)

shiftr_w32 :: Word32 -> Int -> Word32
shiftr_w32 (W32# w) (I# i) = W32# (w `uncheckedShiftRL#`   i)

flush :: Builder
flush = Builder $ \ k buf@(Buffer p o u l) ->
    if u == 0
      then k buf
      else S.PS p o u : k (Buffer p (o+u) 0 l)

emptyBuilder :: Builder
emptyBuilder = Builder id

instance Semigroup Builder where
    (<>) = append

instance Monoid Builder where
    mempty  = emptyBuilder
    mappend = (<>)


-- This caused 6.10.1 to segfault when run with +RTS -hb
-- trac #3001

module Main (main) where

main :: IO ()
main = print $ replicate 40000 'x'


import Control.Concurrent
import Control.Monad (forever)

main = do
    empty <- newEmptyMVar
    exit <- newEmptyMVar
    _ <- forkIO $ threadDelay 200000 >> putMVar exit ()
    _ <- forkIO $ takeMVar empty >> return ()
    _ <- forkIO $ print (sum [1..10000])
    takeMVar exit


import Data.Array.Unboxed

main = do
  let l1 = [1..10] :: [Int]
  let l2 = [ map (i+) l1 | i <- [1..500000] ]
  let l3 = map (\l -> listArray (1,length l) l) l2 :: [UArray Int Int]
  print $ accumulate l3 0

accumulate [] rv = rv
accumulate (h:t) rv =
  let nextRv = (rv + sum (elems h)) in
  accumulate t $! nextRv


fÃ¸b :: Integer -> Integer
fÃ¸b n
  | n == 0 = 0
  | n == 1 = 1
  | n >= 2 = fÃ¸b (n - 1) + fÃ¸b (n - 2)

main :: IO ()
main = print (fÃ¸b 26)


-- Tests for a bug in the handling of cost-centre stacks in the
-- runtime, where we lose the current cost-centre stack when
-- evaluating a function.

{-# NOINLINE f #-}
f :: Int -> Int
f = g   -- here we should remember the stack under which g was evaluated

{-# NOINLINE g #-}
g :: Int -> Int
g x = x + 1

main =  return $! f 3


-- A variant of T5654 where instead of evaluating directly to a
-- function, f evaluates to a new PAP.  This exposes a slightly
-- different but related bug, where when we create a new PAP by
-- applying arguments to an existing PAP, we should take into account
-- the stack on the original PAP.

-- The stack we should see is main->f->g->h, but if we get this wrong
-- (GHC 7.10) then the stack is main->f->h.

{-# NOINLINE f #-}
f :: Int -> Int
f = g 3

{-# NOINLINE g #-}
g :: Int -> Int -> Int
g = h 4

{-# NOINLINE h #-}
h :: Int -> Int -> Int -> Int
h x y z = x + y + z

main =  return $! f 5


foo :: (() -> () -> [()] -> [()]) -> () -> [()] -> [()]
foo k =
  \_ xs -> concatMap ($ [head xs]) [bar]
 where
  bar =
    let k' = k undefined undefined
    in  \xs ->
          let k'' = [k' xs]
          in  (() : (foldr1 (>>) k''))

k :: () -> [()] -> [()]
k = foo (\_ -> k)

--k a = foo (\_ -> k) a

-- all the work should happen in r
r :: ()
r = k undefined [] !! 4000

main = print r


-- test for #949: the -hy heap profile should not include
-- "stg_ap_2_upd" or similar

main = length xs `seq` return xs
  where xs = map (+1) [1..1000000]


module Main where

f1 :: Int -> Int
f1 = (+ 1)

f2 :: Int -> Int
f2 = f3 . f3 . f3
  where
    f3 :: Int -> Int
    f3 = (* 123)
    {-# SCC f3 "bar" #-}
    {-# NOINLINE f3 #-}

main :: IO ()
main = readLn >>= print . f2 . f1

{-# NOINLINE f1 #-}
{-# NOINLINE f2 #-}

{-# SCC f1 #-}
{-# SCC f2 "foo" #-}


module Main (main) -- q
where {
--import Fast2haskell;

    f_queens a_n=f_queens' (enumFromTo (1 :: Int) a_n) a_n;
    f_queens' a_positions 0=(:) [] [];
    f_queens' a_positions a_n=c_concat (f_map (f_place (f_queens' a_positions (((-) :: (Int -> Int -> Int)) a_n (1 :: Int)))) a_positions);
    f_place a_boards a_q=[(:) a_q a_bs|a_bs<-a_boards,f_safe (1 :: Int) a_q a_bs];
    f_safe a_d a_q []=True;
    f_safe a_d a_q (a_h:a_t)=
        if (((==) :: (Int -> Int -> Bool)) a_q a_h)
        then False
        else
        if (((==) :: (Int -> Int -> Bool)) (f_absi (((-) :: (Int -> Int -> Int)) a_q a_h)) a_d)
        then False
        else
            (f_safe (((+) :: (Int -> Int -> Int)) a_d (1 :: Int)) a_q a_t);
    f_absi a_n=
        if (((<) :: (Int -> Int -> Bool)) a_n (0 :: Int))
        then (((negate) :: (Int -> Int)) a_n)
        else
            a_n;
    f_main a_n=(++) (show (length (f_queens a_n))) "\n";
    c_input=(10 :: Int);
    c_concat=f_foldr (++) [];
    f_foldr a_op a_r []=a_r;
    f_foldr a_op a_r (a_a:a_x)=a_op a_a (f_foldr a_op a_r a_x);
    f_map a_f a_x=[a_f a_a|a_a<-a_x];
    main = putStr (f_main c_input)
}


-- Evaluator in a monad: with execution counts
-- Phil Wadler, 11 October 1991

-- Types are optional.  Some must be commented out to
-- work around a bug in Gofer.

-- The count monad

type  M a               =  (a, Int)

unit                    :: a -> M a
unit a                  =  (a, 0)

bind                    :: M a -> (a -> M b) -> M b
m `bind` k              =  case m of
                             (a,i) -> case k a of
                                        (b,j) -> (b,i+j)

-- disp                 :: Text a => M a -> String
disp (a,i)              =  show a ++ "\nCount: " ++ show i

tick                    :: M ()
tick                    =  ((), 1)

-- The evaluator
-- Lines with * are only change from evalIdent

data  Op                =  Add | Sub | Mul | Quo
data  Term              =  Con Int | Bin Op Term Term

eval                    :: Term -> M Int
eval (Con i)            =  unit i
eval (Bin op u v)       =  eval u     `bind` (\a  ->
                           eval v     `bind` (\b  ->
                           go op a b  `bind` (\c  ->    -- *
                           tick       `bind` (\ () ->   -- *
                           unit c))))                   -- *

go                      :: Op -> Int -> Int -> M Int
go Add a b              =  unit (a+b)
go Sub a b              =  unit (a-b)
go Mul a b              =  unit (a*b)
go Quo a b              =  unit (a `quot` b) -- WDP: was "div"

test                    :: Term -> String
test t                  =  disp (eval t)

-- Test data

add, sub, mul, quo      :: Term -> Term -> Term
u `add` v               =  Bin Add u v
u `sub` v               =  Bin Sub u v
u `mul` v               =  Bin Mul u v
u `quo` v               =  Bin Quo u v

term0,term1,term2       :: Term
term0                   =  Con 6 `mul` Con 9
term1                   =  (Con 4 `mul` Con 13) `add` Con 2
term2                   =  (Con 1 `quo` Con 2) `add` Con 2
term3                   =  ((((((((((((((((((((((((((((((((
                           ((((((((((((((((((((((((((((((
                                 Con 7777 `mul` Con  13) `quo` Con  13)
                           `mul` Con 755) `quo` Con 755) `mul` Con 333)
                           `quo` Con 755) `mul` Con 755) `mul` Con 333)
                           `mul` Con 755) `quo` Con 755) `mul` Con 333)
                           `quo` Con 755) `mul` Con 755) `mul` Con 333)
                           `mul` Con 755) `quo` Con 755) `mul` Con 333)
                           `quo` Con 755) `mul` Con 755) `mul` Con 333)
                           `mul` Con 755) `quo` Con 755) `mul` Con 333)
                           `quo` Con 755) `mul` Con 755) `mul` Con 333)
                           `mul` Con 755) `quo` Con 755) `mul` Con 333)
                           `quo` Con 755) `mul` Con 755) `mul` Con 333)
                           `mul` Con 755) `quo` Con 755) `mul` Con 333)
                           `quo` Con 755) `mul` Con 755) `mul` Con 333)
                           `mul` Con 755) `quo` Con 755) `mul` Con 333)
                           `quo` Con 755) `mul` Con 755) `mul` Con 333)
                           `mul` Con 755) `quo` Con 755) `mul` Con 333)
                           `quo` Con 755) `mul` Con 755) `mul` Con 333)
                           `mul` Con 755) `quo` Con 755) `mul` Con 333)
                           `quo` Con 755) `mul` Con 755) `mul` Con 333)
                           `mul` Con 755) `quo` Con 755) `mul` Con 333)
                           `quo` Con 755) `mul` Con 755) `mul` Con 333)

sb 0 = term2
sb n = if (n `mod` 2) == 0
       then term2 `add` (sb (n-1))
       else term2 `sub` (sb (n-1))

main = print (show (eval (sb 5000)))


 module DataTypes where

 import GenUtils
 import Data.Array -- 1.3
 import Data.Ix
 import Data.Char
 infix 1 =: -- 1.3
 (=:) a b = (a,b)

 class Presentable a where
       userFormat :: a -> String       -- in prefered display format

 instance (Presentable a) => Presentable [a] where
     userFormat xs = unlines (map userFormat xs)

 data Piece
       = King
       | Queen
       | Rook
       | Knight
       | Bishop
       | Pawn deriving(Eq)

 instance Presentable Piece where
   userFormat King   = "K"
   userFormat Queen  = "Q"
   userFormat Rook   = "R"
   userFormat Knight = "N"
   userFormat Bishop = "B"
   userFormat Pawn   = "P"

 castleK = "O-O"
 castleQ = "O-O-O"

 data Colour = Black | White deriving (Eq)

 instance Presentable Colour where
       userFormat White = "White"
       userFormat Black = "Black"

 changeColour :: Colour -> Colour
 changeColour White = Black
 changeColour Black = White

 type ChessRank = Int  -- 1-8
 type ChessFile = Int  -- 1-8

 type BoardPos = (ChessFile,ChessRank) -- ChessFile (0-7) and ChessRank (0-7)
 type ExBoardPos = (Maybe ChessFile,Maybe ChessRank)

 extendBP :: BoardPos -> ExBoardPos
 extendBP (a,b) = (Just a,Just b)

 compExBPandBP :: ExBoardPos -> BoardPos -> Bool
 compExBPandBP (a,b) (c,d) = a `cmp` c && b `cmp` d
    where
       cmp Nothing  _ = True
       cmp (Just x) y = x == y

 userFormatBoardPos :: BoardPos -> String
 userFormatBoardPos (f,r) = userFormatFile f ++ userFormatRank r
 userFormatExBoardPos :: ExBoardPos -> String
 userFormatExBoardPos (Just f,Just r)  = userFormatFile f ++ userFormatRank r
 userFormatExBoardPos (Just f,Nothing) = userFormatFile f
 userFormatExBoardPos (Nothing,Just r) = userFormatRank r
 userFormatExBoardPos _ = ""
 userFormatRank r = [toEnum (r + 48)]
 userFormatFile f = [toEnum (f + 96)]

 data MoveTok
       = PieceTok Piece        -- Q,K,R,B,N
       | RankTok ChessRank     -- 1 .. 8
       | FileTok ChessFile     -- a .. h
       | PartCastleTok         -- 0 | O | o
       | CaptureTok            -- x
       | MoveToTok             -- -
       | QueensWith            -- =
       | CheckTok              -- +
       | MateTok               -- #

 charToMoveTok 'Q' = Just (PieceTok Queen)
 charToMoveTok 'K' = Just (PieceTok King)
 charToMoveTok 'R' = Just (PieceTok Rook)
 charToMoveTok 'B' = Just (PieceTok Bishop)
 charToMoveTok 'N' = Just (PieceTok Knight)
 charToMoveTok '1' = Just (RankTok 1)
 charToMoveTok '2' = Just (RankTok 2)
 charToMoveTok '3' = Just (RankTok 3)
 charToMoveTok '4' = Just (RankTok 4)
 charToMoveTok '5' = Just (RankTok 5)
 charToMoveTok '6' = Just (RankTok 6)
 charToMoveTok '7' = Just (RankTok 7)
 charToMoveTok '8' = Just (RankTok 8)
 charToMoveTok 'a' = Just (FileTok 1)
 charToMoveTok 'b' = Just (FileTok 2)
 charToMoveTok 'c' = Just (FileTok 3)
 charToMoveTok 'd' = Just (FileTok 4)
 charToMoveTok 'e' = Just (FileTok 5)
 charToMoveTok 'f' = Just (FileTok 6)
 charToMoveTok 'g' = Just (FileTok 7)
 charToMoveTok 'h' = Just (FileTok 8)
 charToMoveTok '0' = Just (PartCastleTok)
 charToMoveTok 'O' = Just (PartCastleTok)
 charToMoveTok 'o' = Just (PartCastleTok)
 charToMoveTok 'x' = Just (CaptureTok)
 charToMoveTok '-' = Just (MoveToTok)
 charToMoveTok '=' = Just (QueensWith)
 charToMoveTok '+' = Just (CheckTok)
 charToMoveTok '#' = Just (MateTok)
 charToMoveTok _   = Nothing

 data Quantum
       = QuantumMove   String          -- Short Description of move
                       String          -- Check or Mate (+ or #)
                       String          -- !,??,?!, etc
                       Board           -- Snap Shot of Board
       | QuantumNAG Int                -- !,??,?! stuff
       | QuantumComment [String]       -- { comment }
       | QuantumResult String          -- 1-0, etc (marks end of game)
       | QuantumAnalysis [Quantum]     -- ( analysis )
       | QuantumPrintBoard             -- {^D}

 instance Presentable Quantum where
       userFormat (QuantumMove mv ch ann _)
               = mv ++ ch ++ ann
       userFormat (QuantumNAG nag) = "$" ++ show nag
       userFormat (QuantumComment comment)
               = "[" ++ unwords comment ++ "]"
       --userFormat (QuantumNumber num)  = userFormat num
       userFormat (QuantumResult str) = str
       userFormat (QuantumAnalysis anal) =
               "( " ++ unwords (map userFormat anal) ++ " )"

 data Result = Win | Draw | Loss | Unknown

 instance Presentable Result where
       userFormat Win     = "1-0"
       userFormat Draw    = "1/2-1/2"
       userFormat Loss    = "0-1"
       userFormat Unknown = "*"

 mkResult :: String -> Result
 mkResult "1-0"     = Win
 mkResult "1/2-1/2" = Draw
 mkResult "0-1"     = Loss
 mkResult _         = Unknown

 data TagStr = TagStr String String

 instance Presentable TagStr where
       userFormat (TagStr tag str) = "[" ++ tag ++ " \"" ++ str ++ "\"]"

 getTagStr :: String -> String -> [TagStr] -> String
 getTagStr str def [] = def
 getTagStr str def (TagStr st ans:rest)
               | str == st = ans
               | otherwise = getTagStr str def rest

 getHeaderInfo
       :: [TagStr]
       -> (
               String,         -- Date
               String,         -- Site
               Maybe Int,      -- Game Number
               Result,         -- W/D/L
               String,         -- White
               String,         -- Black
               String          -- Opening
       )
 getHeaderInfo tags = (
               date,
               site,
               gameno,
               result,
               white `par` whiteElo,
               black `par` blackElo,
               opening)
   where
       date   = case getTagStr "Date" "?" tags of
                  [a,b,c,d,'.','?','?','.','?','?'] -> [a,b,c,d]
                  [a,b,c,d,'.',x,y,'.','?','?'] -> getMonth [x,y] ++ " " ++ [a,b,c,d]
                  def -> "?"
       site     = getTagStr "Site" "?" tags
       gameno   = case getTagStr "GameNumber" "" tags of
                       xs | all isDigit xs && not (null xs) -> Just (read xs)
                       _ -> Nothing
       result   = mkResult (getTagStr "Result" "*" tags)
       white    = canon (getTagStr "White" "?" tags)
       whiteElo = getTagStr "WhiteElo" "" tags
       black    = canon (getTagStr "Black" "?" tags)
       blackElo = getTagStr "BlackElo" "" tags
       opening  = getOpening (getTagStr "ECO" "" tags)

       par xs "" = xs
       par xs ys = xs ++ " (" ++ ys ++ ")"

       getMonth "01" = "Jan"
       getMonth "02" = "Feb"
       getMonth "03" = "Mar"
       getMonth "04" = "Apr"
       getMonth "05" = "May"
       getMonth "06" = "Jun"
       getMonth "07" = "Jul"
       getMonth "08" = "Aug"
       getMonth "09" = "Sep"
       getMonth "10" = "Oct"
       getMonth "11" = "Nov"
       getMonth "12" = "Dec"

       canon name = case span (/= ',') name of
                       (a,[',',' ',b]) -> b : ". " ++ a
                       (a,[',',b]) -> b : ". " ++ a
                       (a,',':' ':b) -> b ++ " " ++ a
                       (a,',':b) -> b ++ " " ++ a
                       _ -> name

 getOpening eco@[a,b,c] |  a >= 'A' && a <= 'E' && isDigit b && isDigit c
    = getOpenName ((fromEnum a - fromEnum 'A') * 100
               + (fromEnum b - fromEnum '0') * 10
               + (fromEnum c - fromEnum '0')) ++ " " ++ eco
 getOpening other = other

 getOpenName :: Int -> String
 getOpenName eco
       | otherwise = "Foo"
 {-
       | eco == 000 = "Irregular Openings"
       | eco == 001 = "Larsen Opening"
       | eco == 002 = "From's Gambit and Bird's Open"
       | eco == 003 = "Bird's Opening"
       | eco == 004 = "Dutch System"
       | eco == 005 = "Transposition to various Open"
       | eco == 006 = "Zukertort Opening"
       | eco >= 007 && eco <= 008
                    = "Barcza System"
       | eco == 009 = "Reti Opening"
       | eco == 010 = "Variations of Dutch, QI, KI"
       | eco >= 011 && eco <= 014
                    = "Reti Opening"
       | eco == 015 = "English counter King's Fianch"
       | eco >= 016 && eco <= 039
                    = "English Opening"
       | eco == 040 = "Unusual replies to 1.d4"
       | eco == 041 = "Modern Defence counter 1.d4"
       | eco == 042 = "Modern Defence with c2-c4"
       | eco >= 043 && eco <= 044
                    = "Old Benoni"
       | eco == 045 = "Queen's Pawn-Trompowski Var"
       | eco == 046 = "Queen's Pawn Opening"
       | eco == 047 = "Queen's Indian"
       | eco >= 048 && eco <= 049
                    = "King's Indian"
       | eco == 050 = "Queen's Indian"
       | eco >= 051 && eco <= 052
                    = "Budapest Defence"
       | eco >= 053 && eco <= 056
                    = "Old Indian Defence"
       | eco >= 057 && eco <= 059
                    = "Volga-Benko Gambit"
       | eco >= 060 && eco <= 079
                    = "Benoni"
       | eco >= 080 && eco <= 099
                    = "Dutch Defence"
       | eco == 100 = "Owen Def, Nimzowitsch Def"
       | eco == 101 = "Center Counter"
       | eco >= 102 && eco <= 105
                    = "Alekhine's Defence"
       | eco == 106 = "Modern Defence"
       | eco >= 107 && eco <= 109
                    = "Pirc Defence"
       | eco >= 110 && eco <= 119
                    = "Caro-Kann Defence"
       | eco >= 120 && eco <= 199
                    = "Sicilian Defence"
       | eco >= 200 && eco <= 219
                    = "French Defence"
       | eco == 220 = "Rare moves"
       | eco == 221 = "Nordic Gambit"
       | eco == 222 = "Central Gambit"
       | eco >= 223 && eco <= 224
                    = "Bishop's Opening"
       | eco >= 225 && eco <= 229
                    = "Vienna Game"
       | eco == 230 = "King's Gambit Declined"
       | eco >= 231 && eco <= 232
                    = "Falkbeer Counter Gambit"
       | eco >= 233 && eco <= 239
                    = "King's Gambit"
       | eco == 240 = "Latvian Gambit"
       | eco == 241 = "Philidor Defence"
       | eco >= 242 && eco <= 243
                    = "Russian Defence-Petrov"
       | eco >= 244 && eco <= 245
                    = "Scotch Opening"
       | eco >= 246 && eco <= 249
                    = "Four Knight's"
       | eco == 250 = "Italian Opening"
       | eco >= 251 && eco <= 252
                    = "Evans Gambit"
       | eco >= 253 && eco <= 254
                    = "Italian Opening"
       | eco >= 255 && eco <= 259
                    = "Two Knight's Play"
       | eco >= 260 && eco <= 299
                    = "Ruy Lopez"
       | eco >= 300 && eco <= 305
                    = "Queen Pawn's Opening"
       | eco >= 306 && eco <= 307
                    = "Queen's Gambit"
       | eco >= 308 && eco <= 309
                    = "Albins Counter Gambit"
       | eco >= 310 && eco <= 319
                    = "Slav Defence"
       | eco >= 320 && eco <= 329
                    = "Queen's Gambit Accepted"
       | eco >= 330 && eco <= 369
                    = "Queen's Gambit"
       | eco >= 370 && eco <= 399
                    = "Gruenfeld Defence"
       | eco >= 400 && eco <= 409
                    = "Catalan"
       | eco == 410 = "Blumenfeld Gambit"
       | eco >= 411 && eco <= 419
                    = "Queen's Indian"
       | eco >= 420 && eco <= 459
                    = "Nimzo Indian"
       | eco >= 460 && eco <= 499
                    = "King's Indian"
 -}

 data MoveNumber = MoveNumber Int Colour
 instance Presentable MoveNumber where
       userFormat (MoveNumber n White)  = show n ++ "."
       userFormat (MoveNumber n Black)  = show n ++ "..."

 initMoveNumber = MoveNumber 1 White
 incMove (MoveNumber i White) = MoveNumber i Black
 incMove (MoveNumber i Black) = MoveNumber (i+1) White
 decMove (MoveNumber i White) = MoveNumber (i-1) Black
 decMove (MoveNumber i Black) = MoveNumber i White
 getMoveColour :: MoveNumber -> Colour
 getMoveColour (MoveNumber _ c) = c

 data Token

       = StringToken   String
       | AsterixToken
       | LeftABToken           -- ??
       | RightABToken          -- ??
       | NAGToken      Int     -- `normal' NAGS
       | NAGAnnToken   Int String
                               -- `special' move annotating NAGS (1-6)
       | SymbolToken   String
       | CommentToken  [String] -- list of words
       | LeftSBToken
       | RightSBToken
       | LeftRBToken
       | RightRBToken
       | IntToken      Int
       | PeriodToken

       | AnalToken     [Token]

 instance Presentable Token where
       userFormat (StringToken str) = show str
       userFormat (IntToken n)      = show n
       userFormat (PeriodToken)     = "."
       userFormat (AsterixToken)    = "*"
       userFormat (LeftSBToken)     = "["
       userFormat (RightSBToken)    = "]"
       userFormat (LeftRBToken)     = "("
       userFormat (RightRBToken)    = ")"
       userFormat (LeftABToken)     = "<"
       userFormat (RightABToken)    = ">"
       userFormat (NAGToken i)      = "$" ++ show i
       userFormat (NAGAnnToken i s) = "$" ++ show i
       userFormat (SymbolToken str) = str
       userFormat (CommentToken str) = "{" ++ unwords str ++ "}"
       userFormat (AnalToken toks) = "( " ++ unwords (map userFormat toks)
                                       ++ " )"

 data Game a = Game [TagStr] [a]

 type AbsGame = Game Token
 type RealGame = Game Quantum

 instance (Presentable a) => Presentable (Game a) where
       userFormat (Game tags toks) =
               unlines (map userFormat tags
                  ++ formatText 78 (map userFormat toks))

 data PlayMove
       = PlayMove
               Piece           -- with this
               BoardPos        -- from here
               BoardPos        -- to here (possibly capturing)
               SpecialMove

 mkPlayMove p f t = PlayMove p f t NothingSpecial

 data SpecialMove
       = NothingSpecial
       | BigPawnMove           -- allows e.p. next move
       | Queening Piece        -- queen with this
       | EnPassant             -- capture e.p.
    deriving (Eq)

 instance Presentable PlayMove where
       userFormat (PlayMove piece pos pos' sp) =
               userFormat piece ++
               userFormatBoardPos pos ++ "-" ++
               userFormatBoardPos pos' ++
               userFormat sp

 instance Presentable SpecialMove where
       userFormat (NothingSpecial) = ""
       userFormat (BigPawnMove) = "{b.p.m.}"
       userFormat (Queening p) = "=" ++ userFormat p
       userFormat (EnPassant) = "e.p."

 extractSrcFromPlayMove :: PlayMove -> BoardPos
 extractSrcFromPlayMove (PlayMove _ src _ _) = src

 extractDestFromPlayMove :: PlayMove -> BoardPos
 extractDestFromPlayMove (PlayMove _ _ dest _)       = dest

 extractSpecialFromPlayMove :: PlayMove -> SpecialMove
 extractSpecialFromPlayMove (PlayMove _ _ _ sp)       = sp

 data BoardSquare
       = VacantSq
       | WhitesSq Piece
       | BlacksSq Piece

 data SquareContent
       = Vacant
       | Friendly
       | Baddy
       | OffBoard deriving (Eq)

 instance Presentable SquareContent where
       userFormat Vacant   = "."
       userFormat Friendly = "*"
       userFormat Baddy    = "#"
       userFormat OffBoard = "?"

 data Board
       = Board (Array BoardPos BoardSquare)
               MoveNumber              -- current player & and move
               (Maybe ChessFile)       -- e.p. possibilities.

 displayBoard :: Colour -> Board -> [String]
 displayBoard col (Board arr _ ep) =
       ([cjustify 33 (userFormat (changeColour col)),""] ++
       [
   concat [ (case (even x,even y) of
       (True,True)   -> showSq (x `div` 2) (y `div` 2)
       (False,False) -> "+"
       (True,False)  -> "---"
       (False,True)  -> (if x == 17 then "| " ++ show (y `div` 2) else "|"))
               | x <- [1..17::Int]]
               | y <- reverse [1..17::Int]] ++
       [concat [ "  " ++ [x] ++ " " | x <- "abcdefgh" ]] ++
       ["",cjustify 33 (userFormat col),"",
               case ep of
                Nothing -> ""
                Just p -> "EnPassant:" ++ userFormatFile p ])
    where
       make n str = take n (str ++ repeat ' ')
       lookupPlace :: Int -> Int -> BoardSquare
       lookupPlace x' y' = arr ! (x',y')

       bold :: String -> String
       bold str = map toLower str

       showSq x y = case lookupPlace x y of
               VacantSq     -> [if_dot,if_dot,if_dot]
               (WhitesSq p) -> (if_dot : userFormat p) ++ [if_dot]
               (BlacksSq p)  -> (if_dot : bold (userFormat p)) ++ [if_dot]
          where
               if_dot = if (x - y) `rem` 2 == 0 then '.' else ' '

 instance Presentable Board where
   userFormat = unlines . displayBoard White

 boardSize :: (BoardPos,BoardPos)
 boardSize = ((1,1),(8,8))

 buildBoard :: String -> Board
 buildBoard str = Board brd initMoveNumber Nothing
    where
       brd = array boardSize (zipWith (=:) allSq (mkPieces str))
       allSq = [ (x,y) | y <- reverse [1..8::Int],x <- [1..8::Int]]
       mkPieces :: String -> [BoardSquare]
       mkPieces (hd:rest) | hd `elem` "KQRNBPkqrnbp" = pc : mkPieces rest
          where
               pc = case hd of
                       'K' -> WhitesSq King
                       'Q' -> WhitesSq Queen
                       'R' -> WhitesSq Rook
                       'N' -> WhitesSq Knight
                       'B' -> WhitesSq Bishop
                       'P' -> WhitesSq Pawn
                       'k' -> BlacksSq King
                       'q' -> BlacksSq Queen
                       'r' -> BlacksSq Rook
                       'n' -> BlacksSq Knight
                       'b' -> BlacksSq Bishop
                       'p' -> BlacksSq Pawn
       mkPieces ('/':rest) = mkPieces rest
       mkPieces (c:rest) | isDigit c =
               case span isDigit rest of
                 (cs,rest') -> take (read (c:cs)) (repeat VacantSq)
                                       ++ mkPieces rest'
       mkPieces [] = []

 startBoard :: Board   -- the uni before the big bang.
 startBoard = buildBoard "rnbqkbnr/pppppppp/32/PPPPPPPP/RNBQKBNR"

 lookupSquare :: Colour -> BoardSquare -> SquareContent
 lookupSquare _      VacantSq    = Vacant
 lookupSquare White (WhitesSq p) = Friendly
 lookupSquare Black (WhitesSq p) = Baddy
 lookupSquare White (BlacksSq p) = Baddy
 lookupSquare Black (BlacksSq p) = Friendly

 lookupBoard :: Board -> BoardPos -> SquareContent
 lookupBoard (Board arr col _) pos =
       if inRange boardSize pos
       then lookupSquare (getMoveColour col) (arr ! pos)
       else OffBoard

 lookupBoardSquare :: Board -> BoardPos -> BoardSquare
 lookupBoardSquare (Board arr _ _) pos = arr ! pos

 getSquarePiece :: BoardSquare -> Maybe Piece
 getSquarePiece VacantSq    = Nothing
 getSquarePiece (WhitesSq p) = Just p
 getSquarePiece (BlacksSq p) = Just p

 lookupBoardPiece :: Board -> BoardPos -> Maybe Piece
 lookupBoardPiece (Board arr _ _) pos =
     case arr ! pos of
       VacantSq -> Nothing
       WhitesSq piece -> Just piece
       BlacksSq piece -> Just piece

 {-# INLINE mkColBoardSq #-}
 mkColBoardSq :: Colour -> Piece -> BoardSquare
 mkColBoardSq White p = WhitesSq p
 mkColBoardSq Black p = BlacksSq p

 getBoardColour (Board _ mv _) = getMoveColour mv


module GenUtils (

        trace,

      assocMaybe, assocMaybeErr,
      arrElem,
      arrCond,
      memoise,
      Maybe(..),
      MaybeErr(..),
      mapMaybe,
      mapMaybeFail,
      maybeToBool,
      maybeToObj,
      maybeMap,
      joinMaybe,
      mkClosure,
      foldb,

      mapAccumL,

      sortWith,
      sort,
      cjustify,
      ljustify,
      rjustify,
      space,
      copy,
      combinePairs,
      formatText ) where

import Data.Array -- 1.3
import Data.Ix    -- 1.3

import Debug.Trace ( trace )

-- -------------------------------------------------------------------------

-- Here are two defs that everyone seems to define ...
-- HBC has it in one of its builtin modules

infix 1 =: -- 1.3
type Assoc a b = (a,b) -- 1.3
(=:) a b = (a,b)

mapMaybe :: (a -> Maybe b) -> [a] -> [b]
mapMaybe f [] = []
mapMaybe f (a:r) = case f a of
                      Nothing -> mapMaybe f r
                      Just b  -> b : mapMaybe f r

-- This version returns nothing, if *any* one fails.

mapMaybeFail f (x:xs) = case f x of
                        Just x' -> case mapMaybeFail f xs of
                                    Just xs' -> Just (x':xs')
                                    Nothing -> Nothing
                        Nothing -> Nothing
mapMaybeFail f [] = Just []

maybeToBool :: Maybe a -> Bool
maybeToBool (Just _) = True
maybeToBool _        = False

maybeToObj  :: Maybe a -> a
maybeToObj (Just a) = a
maybeToObj _        = error "Trying to extract object from a Nothing"

maybeMap :: (a -> b) -> Maybe a -> Maybe b
maybeMap f (Just a) = Just (f a)
maybeMap f Nothing  = Nothing

joinMaybe :: (a -> a -> a) -> Maybe a -> Maybe a -> Maybe a
joinMaybe _ Nothing  Nothing  = Nothing
joinMaybe _ (Just g) Nothing  = Just g
joinMaybe _ Nothing  (Just g) = Just g
joinMaybe f (Just g) (Just h) = Just (f g h)

data MaybeErr a err = Succeeded a | Failed err deriving (Eq,Show{-was:Text-})

-- @mkClosure@ makes a closure, when given a comparison and iteration loop.
-- Be careful, because if the functional always makes the object different,
-- This will never terminate.

mkClosure :: (a -> a -> Bool) -> (a -> a) -> a -> a
mkClosure eq f = match . iterate f
  where
      match (a:b:c) | a `eq` b = a
      match (_:c)              = match c

-- fold-binary.
-- It combines the element of the list argument in balanced mannerism.

foldb :: (a -> a -> a) -> [a] -> a
foldb f [] = error "can't reduce an empty list using foldb"
foldb f [x] = x
foldb f l  = foldb f (foldb' l)
   where
      foldb' (x:y:x':y':xs) = f (f x y) (f x' y') : foldb' xs
      foldb' (x:y:xs) = f x y : foldb' xs
      foldb' xs = xs

-- Merge two ordered lists into one ordered list.

mergeWith               :: (a -> a -> Bool) -> [a] -> [a] -> [a]
mergeWith _ []     ys      = ys
mergeWith _ xs     []      = xs
mergeWith le (x:xs) (y:ys)
       | x `le` y  = x : mergeWith le xs (y:ys)
       | otherwise = y : mergeWith le (x:xs) ys

insertWith              :: (a -> a -> Bool) -> a -> [a] -> [a]
insertWith _ x []          = [x]
insertWith le x (y:ys)
       | x `le` y     = x:y:ys
       | otherwise    = y:insertWith le x ys

-- Sorting is something almost every program needs, and this is the
-- quickest sorting function I know of.

sortWith :: (a -> a -> Bool) -> [a] -> [a]
sortWith le [] = []
sortWith le lst = foldb (mergeWith le) (splitList lst)
  where
      splitList (a1:a2:a3:a4:a5:xs) =
               insertWith le a1
              (insertWith le a2
              (insertWith le a3
              (insertWith le a4 [a5]))) : splitList xs
      splitList [] = []
      splitList (r:rs) = [foldr (insertWith le) [r] rs]

sort :: (Ord a) => [a] -> [a]
sort = sortWith (<=)

-- Gofer-like stuff:

cjustify, ljustify, rjustify :: Int -> String -> String
cjustify n s = space halfm ++ s ++ space (m - halfm)
               where m     = n - length s
                     halfm = m `div` 2
ljustify n s = s ++ space (max 0 (n - length s))
rjustify n s = space (max 0 (n - length s)) ++ s

space       :: Int -> String
space n      = copy n ' '

copy  :: Int -> a -> [a]      -- make list of n copies of x
copy n x = take n xs where xs = x:xs

combinePairs :: (Ord a) => [(a,b)] -> [(a,[b])]
combinePairs xs =
        combine [ (a,[b]) | (a,b) <- sortWith (\ (a,_) (b,_) -> a <= b) xs]
 where
        combine [] = []
        combine ((a,b):(c,d):r) | a == c = combine ((a,b++d) : r)
        combine (a:r) = a : combine r

assocMaybe :: (Eq a) => [(a,b)] -> a -> Maybe b
assocMaybe env k = case [ val | (key,val) <- env, k == key] of
               [] -> Nothing
               (val:vs) -> Just val

assocMaybeErr :: (Eq a) => [(a,b)] -> a -> MaybeErr b String
assocMaybeErr env k = case [ val | (key,val) <- env, k == key] of
                       [] -> Failed "assoc: "
                       (val:vs) -> Succeeded val

deSucc (Succeeded e) = e

mapAccumL :: (a -> b -> (c,a)) -> a -> [b] -> ([c],a)
mapAccumL f s [] = ([],s)
mapAccumL f s (b:bs) = (c:cs,s'')
        where
                (c,s') = f s b
                (cs,s'') = mapAccumL f s' bs

-- Now some utilities involving arrays.
-- Here is a version of @elem@ that uses partial application
-- to optimise lookup.

arrElem :: (Ix a) => [a] -> a -> Bool
arrElem obj = \x -> inRange size x && arr ! x
  where
      size = (maximum obj,minimum obj)
      arr = listArray size [ i `elem` obj | i <- range size ]

-- Here is the functional version of a multi-way conditional,
-- again using arrays, of course. Remember @b@ can be a function !
-- Note again the use of partiual application.

arrCond :: (Ix a)
        => (a,a)                      -- the bounds
        -> [(Assoc [a] b)]            -- the simple lookups
        -> [(Assoc (a -> Bool) b)]    -- the functional lookups
        -> b                          -- the default
        -> a -> b                     -- the (functional) result

arrCond bds pairs fnPairs def = (!) arr'
  where
      arr' = array bds [ t =: head
                      ([ r | (p, r) <- pairs, elem t p ] ++
                       [ r | (f, r) <- fnPairs, f t ] ++
                       [ def ])
              | t <- range bds ]

memoise :: (Ix a) => (a,a) -> (a -> b) -> a -> b
memoise bds f = (!) arr
  where arr = array bds [ t =: f t | t <- range bds ]

-- Quite neat this. Formats text to fit in a column.

formatText :: Int -> [String] -> [String]
formatText n = map unwords . cutAt n []
  where
        cutAt :: Int -> [String] -> [String] -> [[String]]
        cutAt m wds [] = [reverse wds]
        cutAt m wds (wd:rest) = if len <= m || null wds
                                then cutAt (m-(len+1)) (wd:wds) rest
                                else reverse wds : cutAt n [] (wd:rest)
          where len = length wd


 module Interp (runInterp) where

 import GenUtils
 import DataTypes
 import InterpUtils
 import Parser (pgnLexer)

 runInterp :: AbsGame -> RealGame
 runInterp (Game tags toks) = Game tags (pgnInterp toks initParState)

 initParState = (FirstBoard startBoard)

 type Par a = StoreBoard -> a
 thenP :: Par a -> (a -> Par b) -> Par b
 returnP :: a -> Par a

 returnP a = \s -> a
 thenP m k s = case m s of
                 r -> k r s

 failP a = \s -> error a
 consP q rest = \s -> q : pgnInterp rest s
 thenP' :: Par StoreBoard -> Par a -> Par a
 thenP' m k s = case m s of
                 r -> k r
 newGameP :: Par a -> Par a
 newGameP m = \ _ -> m initParState

 getCurrColour :: Par Colour
 getCurrColour =
       getBoard                `thenP` \ (Board _ (MoveNumber _ col) _) ->
       returnP col

 checkColour :: MoveNumber -> Par ()
 checkColour (MoveNumber i col) =
       getBoard                `thenP` \ (Board _ (MoveNumber i' col') _) ->
       if i == i' && col == col'
       then returnP ()
       else failP ("number mis-match: "
               ++ userFormat (MoveNumber i col)
               ++ " (looking for "
               ++ userFormat (MoveNumber i' col')
               ++ ")\n")

 data StoreBoard
       = FirstBoard Board
       | UndoableBoard Board {- new -} Board {- back one -}

 updateBoard :: Board -> Par StoreBoard
 updateBoard brd (FirstBoard old_brd)
       = UndoableBoard brd old_brd
 updateBoard brd (UndoableBoard old_brd _)
       = UndoableBoard brd old_brd

 getBoard :: Par Board
 getBoard s@(FirstBoard brd)
       = brd
 getBoard s@(UndoableBoard brd _)
       = brd

 undoBoard :: Par StoreBoard
 undoBoard (FirstBoard _)
       = error "Incorrect start to some analysis"
 undoBoard (UndoableBoard _ old_brd)
       = FirstBoard old_brd

 pgnInterp :: [Token] -> Par [Quantum]
 pgnInterp (IntToken n:PeriodToken:PeriodToken:PeriodToken:rest) =
       checkColour (MoveNumber n Black)                `thenP` \ () ->
       pgnInterp rest
 pgnInterp (IntToken n:PeriodToken:rest) =
       checkColour (MoveNumber n White)                `thenP` \ () ->
       pgnInterp rest

 pgnInterp (SymbolToken str:CommentToken (ann:rs):r)
       | all (flip elem "!?") ann =
       pgnInterp (SymbolToken str:pgnLexer ann ++ (CommentToken rs:r))

 pgnInterp (CommentToken (n:tag:rest):r)
       | head tag == '(' && take 2 (reverse tag) == ":)" && length rest > 1 =
       getCurrColour                           `thenP` \ col ->
       let
           invert Black r   = r -- because the move has *already* happend
           invert _ "0.00"  = "0.00"   -- don't negate 0
           invert _ ('-':r) = r
           invert _ r       = '-':r
       in
       pgnInterp (LeftRBToken:map SymbolToken (take (length rest-1) rest)
               ++ [CommentToken ["Score:",invert col n],RightRBToken] ++ r)

 pgnInterp (CommentToken []:rest) = pgnInterp rest
 pgnInterp (CommentToken comm:rest) =
       consP (QuantumComment comm) rest
 pgnInterp (NAGToken nag:rest) =
       consP (QuantumNAG nag) rest
 pgnInterp (NAGAnnToken nag _:rest) =
       consP (QuantumNAG nag) rest
 pgnInterp (SymbolToken "0-1":rest) =
       consP (QuantumResult "0-1") rest
 pgnInterp (SymbolToken "1-0":rest) =
       consP (QuantumResult "1-0") rest
 pgnInterp (SymbolToken "1/2-1/2":rest) =
       consP (QuantumResult "1/2-1/2") rest
 pgnInterp (AsterixToken:rest) =
       consP (QuantumResult "*") rest
 pgnInterp (SymbolToken move:rest@(NAGAnnToken _ str:_)) =
       getBoard                `thenP` \ brd ->
       parseMove move brd      `thenP` \ (mv,ch,corrMv,new_brd) ->
       updateBoard new_brd     `thenP'`
       consP (QuantumMove mv ch str new_brd) rest
 pgnInterp (SymbolToken move:rest) =
       getBoard                `thenP` \ brd ->
       parseMove move brd      `thenP` \ (mv,ch,corrMv,new_brd) ->
       updateBoard new_brd     `thenP'`
       consP (QuantumMove mv ch "" new_brd) rest
 pgnInterp (LeftRBToken:rest) =
       getAnalysis rest 0 []   `thenP` \ (anal,rest) ->
       (undoBoard              `thenP'`
       pgnInterp anal)         `thenP` \ anal' ->
       consP (QuantumAnalysis anal') rest
 pgnInterp [] = returnP []
 pgnInterp toks = failP ("when reading: "
               ++ unwords (map userFormat (take 10 toks)))

 getAnalysis (t@LeftRBToken:r) n anal = getAnalysis r (n+1) (t:anal)
 getAnalysis (t@RightRBToken:r) n anal
       | n == (0 :: Int) = returnP (reverse anal,r)
       | otherwise = getAnalysis r (n-1) (t:anal)
 getAnalysis (t:r) n anal = getAnalysis r n (t:anal)
 getAnalysis [] n anal = failP "no closing ')'"

 parseMove :: String -> Board -> Par (String,String,String,Board)
 parseMove move brd@(Board _ (MoveNumber _ col) _) =
   case mapMaybeFail charToMoveTok move of
    Nothing -> failP ("strange move:" ++ move)
    Just mv_toks ->
       let
          (chs,mv_toks') = getChecks (reverse mv_toks)
          (queen,mv_toks'') = getQueen mv_toks'
       in
       case parseAlgMove mv_toks'' queen brd of
         (the_mv,new_brd) -> returnP (the_mv,chs,"$$",new_brd)

 parseAlgMove
       :: [MoveTok]
       -> Maybe Piece
       -> Board
       -> (String,Board)
 parseAlgMove [PartCastleTok,MoveToTok,PartCastleTok] Nothing
               = findCastleKMove
 parseAlgMove [PartCastleTok,MoveToTok,PartCastleTok,
                   MoveToTok,PartCastleTok] Nothing
               = findCastleQMove

 parseAlgMove (PieceTok King:r) Nothing   = parsePieceMove r King
 parseAlgMove (PieceTok Queen:r) Nothing  = parsePieceMove r Queen
 parseAlgMove (PieceTok Rook:r) Nothing   = parsePieceMove r Rook
 parseAlgMove (PieceTok Knight:r) Nothing  = parsePieceMove r Knight
 parseAlgMove (PieceTok Bishop:r) Nothing  = parsePieceMove r Bishop

 parseAlgMove [FileTok sf,RankTok sr,MoveToTok,FileTok df,RankTok dr] q  =
       findAPawnMove (extendBP (sf,sr)) (extendBP (df,dr)) q
 parseAlgMove [FileTok sf,RankTok sr,CaptureTok,FileTok df,RankTok dr] q  =
       findAPawnMove (extendBP (sf,sr)) (extendBP (df,dr)) q

 parseAlgMove [FileTok sf,RankTok sr,FileTok df,RankTok dr] q = \ brd ->
   case lookupBoardPiece brd (sf,sr) of
       Nothing -> error ("cant find piece at: " ++ userFormatBoardPos (sf,sr))
       Just Pawn -> findAPawnMove (extendBP (sf,sr)) (extendBP (df,dr)) q brd
       Just King | sf == 5 && df == 7 -> findCastleKMove brd
       Just King | sf == 5 && df == 3 -> findCastleQMove brd
       Just p -> findAMove p (extendBP (sf,sr)) (extendBP (df,dr)) brd

 -- later !

 parseAlgMove [FileTok df,RankTok dr] q =
       findAPawnMove (Nothing,Nothing) (extendBP (df,dr)) q

 parseAlgMove [FileTok sf,CaptureTok,FileTok df,RankTok dr] q  =
       findAPawnMove (Just sf,Nothing) (extendBP (df,dr)) q

 parseAlgMove [FileTok sf,FileTok df] q  =
       findAPawnMove (Just sf,Nothing) (Just df,Nothing) q

 parseAlgMove [FileTok sf,CaptureTok,FileTok df] q  =
       findAPawnMove (Just sf,Nothing) (Just df,Nothing) q
 parseAlgMove _ _ = error "!>!"

 parsePieceMove [FileTok df,RankTok dr] p
       = findAMove p (Nothing,Nothing) (extendBP (df,dr))

 parsePieceMove [CaptureTok,FileTok df,RankTok dr] p
       = findAMove p (Nothing,Nothing) (extendBP (df,dr))

 parsePieceMove [RankTok sr,FileTok df,RankTok dr] p
       = findAMove p (Nothing,Just sr) (extendBP (df,dr))
 parsePieceMove [RankTok sr,CaptureTok,FileTok df,RankTok dr] p
       = findAMove p (Nothing,Just sr) (extendBP (df,dr))

 parsePieceMove [FileTok sf,FileTok df,RankTok dr] p
       = findAMove p (Just sf,Nothing) (extendBP (df,dr))
 parsePieceMove [FileTok sf,CaptureTok,FileTok df,RankTok dr] p
       = findAMove p (Just sf,Nothing) (extendBP (df,dr))

 parsePieceMove [FileTok sf,RankTok sr,MoveToTok,FileTok df,RankTok dr] p
       = findAMove p (extendBP (sf,sr)) (extendBP (df,dr))
 parsePieceMove [FileTok sf,RankTok sr,CaptureTok,FileTok df,RankTok dr] p
       = findAMove p (extendBP (sf,sr)) (extendBP (df,dr))
 parsePieceMove _ p = failP ("syntax error in move:")

 getChecks (CheckTok:CheckTok:r) = ("#",r)
 getChecks (CheckTok:r) = ("+",r)
 getChecks (MateTok:r)  = ("#",r)
 getChecks r            = ("",r)

 getQueen (PieceTok p:QueensWith:r) = (Just p,reverse r)
 getQueen r = (Nothing,reverse r)


 module InterpUtils where

 import GenUtils
 import DataTypes
 import Data.Array -- 1.3

 findCastleKMove brd = (castleK,makeACastleK brd)
 findCastleQMove brd = (castleQ,makeACastleQ brd)

 findAPawnMove
       :: ExBoardPos
       -> ExBoardPos
       -> Maybe Piece
       -> Board
       -> (String,Board)

 findAPawnMove move_src move_dest queen brd@(Board arr mv _)
       = debug (move_txt,new_brd)
   where

       move_colour = getMoveColour mv

       debug   = {- trace (
               {- userFormat brd ++ -}
               userFormat (getMoveColour mv) ++
               -- " (" ++ userFormat absmove ++ ")" ++
               "\nALL   :" ++ unwords (map userFormat all_moves) ++
               "\n") -} id

       correct_src = concat (map (getAllMovesFor brd) currPieces)

       currPieces  =
               [ (Pawn,x,y) |
                       (x,y) <- start_range,
                       r <- [arr ! (x,y)],
                       lookupSquare move_colour r == Friendly,
                       (Just Pawn) <- [getSquarePiece r]]

       start_range
          = case (move_src,move_dest) of
               ((Just f,Just r),_) -> [(f,r)]
               ((Just f,_),_) -> [(f,r) | r <- [2..7]]
               -- no capture !
               (_,(Just f,_)) -> [(f,r) | r <- [2..7]]
               _ -> error "strange pawn move:"

       the_correct_move = if (length correct_move /= 1)
                          then error ("\nAmbiguous move:"
               ++ show (unwords (map userFormat correct_move))
               ++ ":" ++ {- userFormat absmove ++ -} "\n"
               ++ userFormat brd)
               else head correct_move

       correct_move =
               filter (sameQueening queen.extractSpecialFromPlayMove)
               (filter (compExBPandBP move_dest.extractDestFromPlayMove)
                       correct_src)
       sameQueening (Just p) (Queening p') = p == p'
       sameQueening Nothing  (Queening p') = Queen == p'
       sameQueening _ _ = True

       move_txt = createShortMove the_correct_move "" brd
       corr_txt =
           userFormatBoardPos
               (extractSrcFromPlayMove the_correct_move) ++
           userFormatBoardPos
               (extractDestFromPlayMove the_correct_move)
               {- queening ?? -}
       new_brd = makeAMove brd the_correct_move

 findAMove
       :: Piece
       -> ExBoardPos
       -> ExBoardPos
       -> Board
       -> (String,Board)

 findAMove move_piece move_src move_dest brd@(Board arr mv _)
       = debug (move_txt,new_brd)
   where

       move_colour = getMoveColour mv

       debug   = {- trace (
               {- userFormat brd ++ -}
               userFormat (getMoveColour mv) ++
               " (" ++ {- userFormat absmove ++ -} ")" ++
               "\nALL   :" ++ unwords (map userFormat all_moves) ++
               "\nDEST  :" ++ unwords (map userFormat correct_dest) ++
               "\nSRC   :" ++ unwords (map userFormat correct_move) ++
               "\n") -} id

       all_moves = allValidMoves brd move_piece (const True)

       correct_dest = filter
               (compExBPandBP move_dest.extractDestFromPlayMove)
                       all_moves
       correct_move = filter
               (compExBPandBP move_src.extractSrcFromPlayMove)
                       correct_dest
       the_correct_move = if (length correct_move /= 1)
                          then error ("\nAmbiguous move:"
               ++ show (unwords (map userFormat correct_move))
               ++ ":" {- ++ userFormat absmove -} ++ "\n"
               ++ userFormat brd)
               else head correct_move
       disamb = case move_dest of
                 (Just _,Nothing) -> ""        -- fg => fxg4, no disambig.
                 _ -> disAmb
                    (extractSrcFromPlayMove the_correct_move)
                    (map (extractSrcFromPlayMove) correct_dest)

       move_txt = createShortMove the_correct_move disamb brd
       corr_txt =
           userFormatBoardPos
               (extractSrcFromPlayMove the_correct_move) ++
           userFormatBoardPos
               (extractDestFromPlayMove the_correct_move)
               {- queening -}
       new_brd = makeAMove brd the_correct_move
 --partain: findAMove _ _ _ brd = error ("strange move: ")

 allValidMoves :: Board -> Piece -> (ChessFile -> Bool) -> [PlayMove]
 allValidMoves brd piece corr_file
   = concat (map (getAllMovesFor brd) (getCurrPieces brd piece corr_file))

 getCurrPieces
       :: Board
       -> Piece
       -> (ChessFile -> Bool)
       -> [(Piece,ChessFile,ChessRank)]
 getCurrPieces (Board arr (MoveNumber _ col) _) pc corr_file =
       [ (p,x,y) |
               ((x,y), r) <- assocs arr,
               lookupSquare col r == Friendly,
               (Just p) <- [getSquarePiece r],
               p == pc,
               corr_file x
                ]

 getAllMovesFor :: Board -> (Piece,Int,Int) -> [PlayMove]

 getAllMovesFor brd (Rook,x,y) =
       [ mkPlayMove Rook (x,y) (x',y')
         | (x',y') <- (
               movePiece 0    1 brd x y ++
               movePiece 0 (-1) brd x y ++
               movePiece 1    0 brd x y ++
               movePiece (-1) 0 brd x y) ]
 getAllMovesFor brd (Bishop,x,y) =
       [ mkPlayMove Bishop (x,y) (x',y')
         | (x',y') <- (
               movePiece 1      1  brd x y ++
               movePiece 1    (-1) brd x y ++
               movePiece (-1)   1  brd x y ++
               movePiece (-1) (-1) brd x y) ]
 getAllMovesFor brd (Queen,x,y) =
       [ mkPlayMove Queen (x,y) (x',y')
         | (x',y') <- (
               movePiece 0    1    brd x y ++
               movePiece 0 (-1)    brd x y ++
               movePiece 1    0    brd x y ++
               movePiece (-1) 0    brd x y ++
               movePiece 1      1  brd x y ++
               movePiece 1    (-1) brd x y ++
               movePiece (-1)   1  brd x y ++
               movePiece (-1) (-1) brd x y) ]

 getAllMovesFor brd (Knight,x,y) =
       [ mkPlayMove Knight (x,y) (x',y')
           | (xd,yd) <- concat
                       [ [(d1,d2 * 2),(d1 * 2,d2)]
                               | d1 <- [1,-1], d2 <- [1,-1]],
               x' <- [xd + x],
               y' <- [yd + y],
               case lookupBoard brd (x',y') of
                 Vacant -> True
                 Friendly -> False
                 Baddy -> True
                 OffBoard -> False]

 getAllMovesFor brd (King,x,y) =
       [ mkPlayMove King (x,y) (x',y')
           | (xd,yd) <- [(1,1),(1,0),(1,-1),(0,1),
                         (0,-1),(-1,1),(-1,0),(-1,-1)],
               x' <- [xd + x],
               y' <- [yd + y],
               case lookupBoard brd (x',y') of
                 Vacant -> True
                 Friendly -> False
                 Baddy -> True
                 OffBoard -> False]

 getAllMovesFor brd@(Board _ (MoveNumber _ col) may_ep) (Pawn,x,y)
       = real_pawn_moves
   where
       pawn_moves =
               case lookupBoard brd (x,y+del) of
                 Friendly -> []
                 Baddy -> []
                 Vacant -> (mkPlayMove Pawn (x,y) (x,y+del) :
                    if y /= sta then [] else
                    case lookupBoard brd (x,y+del*2) of
                       Friendly -> []
                       Baddy -> []
                       Vacant ->
                         [ PlayMove Pawn (x,y) (x,y+del*2) BigPawnMove])
       left_pc = case lookupBoard brd (x-1,y+del) of
                        Baddy -> [mkPlayMove Pawn (x,y) (x-1,y+del) ]
                        _ -> []
       right_pc = case lookupBoard brd (x+1,y+del) of
                        Baddy -> [mkPlayMove Pawn (x,y) (x+1,y+del) ]
                        _ -> []
       all_pawn_moves = pawn_moves ++ left_pc ++ right_pc
       real_pawn_moves = en_passant ++
               (if y + del == qn       -- if can queens
               then concat [ let fn = PlayMove Pawn f t . Queening
                             in
                               [ fn Queen,
                                 fn Rook,
                                 fn Bishop,
                                 fn Knight ]
                               | PlayMove _ f t _ <- all_pawn_moves ]
                 else all_pawn_moves)
       en_passant =
           case (y == ep,may_ep) of
               (True,Just f) | f == x+1 || f == x-1
                 -> [PlayMove Pawn (x,y) (f,y+del) EnPassant]
               _ -> []
       del,sta,qn,ep :: Int
       (del,sta,qn,ep) -- delta (direction), start, Queening and E.P. Rank
           = case col of
               White -> (1,2,8,5)
               Black -> (-1,7,1,4)

 movePiece xd yd brd x y =
       case lookupBoard brd (x',y') of
         OffBoard -> []
         Friendly -> []
         Baddy    -> [(x',y')]
         Vacant   ->  (x',y') : movePiece xd yd brd x' y'
       where
           x' = x + xd
           y' = y + yd

 makeAMove :: Board -> PlayMove -> Board
 makeAMove board@(Board brd mv@(MoveNumber _ col) _)
       move@(PlayMove piece pos pos' NothingSpecial)  =
       Board (brd //  [ pos =: VacantSq,
                       pos' =: mkColBoardSq col piece ])
                       (incMove mv) Nothing
 makeAMove board@(Board brd mv@(MoveNumber _ col) _)
       move@(PlayMove piece pos@(f,_) pos' BigPawnMove)  =
       Board (brd //  [ pos =: VacantSq,
                       pos' =: mkColBoardSq col piece ])
                       (incMove mv) (Just f)
 makeAMove board@(Board brd mv@(MoveNumber _ col) _)
       move@(PlayMove piece pos@(f,_) pos' (Queening q))  =
       Board (brd //  [ pos =: VacantSq,
                       pos' =: mkColBoardSq col q])
                       (incMove mv) (Just f)
 makeAMove board@(Board brd mv@(MoveNumber _ col) _)   -- ASSERT ?
       move@(PlayMove piece (f,_) (f',_) EnPassant) =
       Board (brd // [ (f,st) =: VacantSq,
                       (f',fn) =: mkColBoardSq col Pawn,
                       (f',st) =: VacantSq ])
                       (incMove mv) Nothing
   where (st,fn) = case col of
                     White -> (5,6)
                     Black -> (4,3)

 makeACastleK (Board brd mv@(MoveNumber _ White) _) =
       Board (brd //
             [ (5,1) =: VacantSq,
               (6,1) =: mkColBoardSq White Rook,
               (7,1) =: mkColBoardSq White King,
               (8,1) =: VacantSq ]) (incMove mv) Nothing
 makeACastleK (Board brd mv@(MoveNumber _ Black) _) =

       Board (brd //
             [ (5,8) =: VacantSq,
               (6,8) =: mkColBoardSq Black Rook,
               (7,8) =: mkColBoardSq Black King,
               (8,8) =: VacantSq ]) (incMove mv) Nothing
 makeACastleQ (Board brd mv@(MoveNumber _ White) _) =
       Board (brd //
             [ (5,1) =: VacantSq,
               (4,1) =: mkColBoardSq White Rook,
               (3,1) =: mkColBoardSq White King,
               (1,1) =: VacantSq ]) (incMove mv) Nothing
 makeACastleQ (Board brd mv@(MoveNumber _ Black) _) =
       Board (brd //
             [ (5,8) =: VacantSq,
               (4,8) =: mkColBoardSq Black Rook,
               (3,8) =: mkColBoardSq Black King,
               (1,8) =: VacantSq ]) (incMove mv) Nothing

 disAmb _ [_] = ""
 disAmb (a,b) t@[(n,m),(x,y)]
       | n == x    = userFormatRank b
       | otherwise = userFormatFile a
 disAmb src lst = error ("PANIC: cant disambiguate: " ++ show src ++ show lst)

 createShortMove :: PlayMove -> String -> Board -> String
 createShortMove (PlayMove Pawn (f,r) dest q) "" brd =
       (if lookupBoard brd dest == Baddy || EnPassant == q
        then userFormatFile f ++ "x" ++ userFormatBoardPos dest
        else userFormatBoardPos dest) ++
       case q of
         Queening p -> "=" ++ userFormat p
         _ -> ""
 createShortMove (PlayMove p _ dest _) extra brd =
       userFormat p ++ extra ++ capt ++ userFormatBoardPos dest
   where
       capt = if lookupBoard brd dest == Baddy
              then "x"
              else ""

 getEPStart :: Colour -> ChessFile
 getEPStart White = 5
 getEPStart Black = 4

 getEPEnd :: Colour -> ChessFile
 getEPEnd White = 6
 getEPEnd Black = 3

 getHomeRank :: Colour -> ChessRank
 getHomeRank White = 1
 getHomeRank Black = 8


 module Main (main) where

 import GenUtils
 import DataTypes
 import Parser
 import Interp
 import PrintTEX

 import System.Environment -- 1.3 (partain)
 import Data.Char -- 1.3

 --fakeArgs = "game001.txt"
 --fakeArgs = "pca2.pgn"
 --fakeArgs = "silly.pgn"
 --fakeArgs = "small.pgn"
 --fakeArgs = "sicil.pgn"
 --fakeArgs = "badgame.pgn"
 --fakeArgs = "mycgames.pgn"
 fakeArgs = "rab.pgn"

 version = "0.3"

 main = do
       [test_dir] <- getArgs
       let (style,fn,filename) = interpArgs (words "-d tex mygames.pgn")
       file <- readFile (test_dir ++ "/" ++filename)
       std_in <- getContents
       let games = pgnParser fn file   -- parse relevant pgn games
       putStr (prog style std_in games)

{- OLD 1.2:
 main =
       getArgs         abort                           $ \ args ->
       --let args = (words "-d tex analgames.pgn") in
       let (style,fn,filename) = interpArgs args in
       readFile filename abort                         $ \ file ->
       readChan stdin abort                            $ \ std_in ->
       let games = pgnParser fn file   -- parse relevant pgn games
       in
       appendChan stdout (prog style std_in games) abort done
-}

 interpArgs :: [String] -> (OutputStyle,Int -> Bool,String)
 --interpArgs [] = (ViewGame,const True,fakeArgs)
 interpArgs [] = interpArgs (words "-d pgn analgames.pgn")
 interpArgs files = interpArgs' OutputPGN (const True) files

 interpArgs' style fn ("-d":"pgn":xs)    = interpArgs' OutputPGN    fn xs
 interpArgs' style fn ("-d":"rawpgn":xs) = interpArgs' OutputRawPGN fn xs
 interpArgs' style fn ("-d":"play":xs)   = interpArgs' ViewGame     fn xs
 interpArgs' style fn ("-d":"parser":xs) = interpArgs' OutputParser fn xs
 interpArgs' style fn ("-d":"tex":xs)    = interpArgs' OutputTEX    fn xs
 interpArgs' style fn ("-d":"head":xs)   = interpArgs' OutputHeader fn xs
 interpArgs' style fn ("-g":range:xs)
       = interpArgs' style (changeFn (parse range)) xs
    where
       changeFn (Digit n:Line:Digit m:r) x = moreChangeFn r x || x >= n && x <= m
       changeFn (Line:Digit m:r) x = moreChangeFn r x || x <= m
       changeFn (Digit n:Line:r) x = moreChangeFn r x || x >= n
       changeFn (Digit n:r) x = moreChangeFn r x || x == n
       changeFn _ _ = rangeError
       moreChangeFn [] = const False
       moreChangeFn (Comma:r) = changeFn r
       moreChangeFn _ = rangeError
       parse xs@(n:_)
               | isDigit n = case span isDigit xs of
                               (dig,rest) -> Digit (read dig) : parse rest
       parse ('-':r) = Line : parse r
       parse (',':r) = Comma : parse r
       parse [] = []
       parse _ = rangeError
       rangeError = error ("incorrect -g option (" ++ range ++ ")\n")

 interpArgs' style fn [file] = (style,fn,file)
 interpArgs' style fn args = error ("bad args: " ++ unwords args)

 data Tok
       = Digit Int             -- n
       | Line                  -- -
       | Comma                 -- ,

 data OutputStyle

       = OutputPGN             -- pgn
       | OutputRawPGN          -- rawpgn
       | OutputHeader          -- header
       | ViewGame              -- play
       | ViewGameEmacs         -- emacs
       | TwoColumn             -- 2col
       | TestGames             -- test
       | OutputTEX

       | OutputParser  -- simply dump out the string read in.
       | CmpGen        -- cmp 2nd and 3rd generations of output

 prog  :: OutputStyle          -- style of action
       -> String               -- stdin (for interactive bits)
       -> [AbsGame]            -- input games
       -> String               -- result
 prog OutputPGN _
               = pgnPrinter True       -- print out game(s)
               . map runInterp         -- interprete all games
 prog OutputRawPGN _
               = pgnPrinter False      -- print out game(s)
               . map runInterp         -- interprete all games
 prog OutputHeader _
               = pgnHeadPrinter        -- print out game(s) headers
               . map runInterp         -- interprete all games
 prog OutputTEX _
               = texPrinter            -- print out game(s)
               . map runInterp         -- interprete all games
 prog ViewGame std_in
               = interactViewer std_in -- print out game(s)
               . runInterp             -- interprete the game
               . head                  -- should check for only *one* object
 prog OutputParser _
               = userFormat

 type PrintState = (Bool,MoveNumber)

 pgnPrinter :: Bool -> [RealGame] -> String
 pgnPrinter detail = unlines . concat . map printGame
   where
       printMoveNumber :: Bool -> MoveNumber -> String
       printMoveNumber False (MoveNumber _ Black) = ""
       printMoveNumber _     mvnum = userFormat mvnum ++ " "

       printQuantums :: PrintState -> [Quantum] -> [String]
       printQuantums ps = concat . fst . mapAccumL printQuantum ps

       printQuantum :: PrintState -> Quantum -> ([String],PrintState)
       printQuantum (pnt,mv) (QuantumMove move ch an brd) =
               ([printMoveNumber pnt mv ++ move ++ ch],(False,incMove mv))
       printQuantum (pnt,mv) (QuantumNAG i) =
               if detail
               then (["$" ++ show i],(False,mv))
               else ([],(False,mv))
       printQuantum (pnt,mv) (QuantumComment comms) =
               if detail
               then ("{" : comms ++ ["}"],(True,mv))
               else ([],(False,mv))
       printQuantum (pnt,mv) (QuantumAnalysis anal) =
               if detail
               then ("(" : printQuantums (True,decMove mv) anal ++ [")"],
                       (True,mv))
               else ([],(False,mv))
       printQuantum (pnt,mv) (QuantumResult str) = ([str],(True,mv))
       printQuantum _ _ = error "PANIC: strange Quantum"

       printGame :: RealGame -> [String]
       printGame (Game tags qu) =
               [ userFormat tag | tag <- tags] ++
               formatText 75 (printQuantums (False,initMoveNumber) qu)

 printHeadGame :: RealGame -> [String]
 printHeadGame (Game tags qu) = [
       rjustify 4 gameno ++ " " ++
       take 20 (rjustify 20 white) ++ " - " ++
       take 20 (ljustify 20 black) ++ " " ++
       take 26 (ljustify 28 site) ++ " " ++ result ]
   where
       (date,site,game_no,res,white,black,opening) = getHeaderInfo tags
       gameno = case game_no of
                 Nothing -> ""
                 Just n -> show n
       result = userFormat res

 pgnHeadPrinter :: [RealGame] -> String
 pgnHeadPrinter = unlines . concat . map printHeadGame

 interactViewer :: String -> RealGame -> String
 interactViewer stdin (Game tags qu) = replayQ qu (lines stdin)

 replayQ (QuantumMove _ _ _ brd:rest) std_in
       = "\027[H" ++ userFormat brd ++ waitQ rest std_in
 replayQ (_:rest) std_in = replayQ rest std_in
 replayQ [] _ = []

 waitQ game std_in = ">>" ++
    (case std_in of
       [] -> ""
       (q:qs) -> replayQ game qs)


 module Parser (pgnLexer,pgnParser) where

 import GenUtils
 import DataTypes
 import Data.Char -- 1.3

 pgnLexer :: String -> [Token]
 pgnLexer ('.':r) = PeriodToken  : pgnLexer r
 pgnLexer ('*':r) = AsterixToken : pgnLexer r
 pgnLexer ('[':r) = LeftSBToken  : pgnLexer r
 pgnLexer (']':r) = RightSBToken : pgnLexer r
 pgnLexer ('(':r) = LeftRBToken  : pgnLexer r
 pgnLexer (')':r) = RightRBToken : pgnLexer r
 pgnLexer ('<':r) = LeftABToken  : pgnLexer r
 pgnLexer ('>':r) = RightABToken : pgnLexer r
 pgnLexer ('"':r) = readString r ""
 pgnLexer ('{':r) = readComment r ""
 pgnLexer ('$':r) = readNAG r ""
 pgnLexer ('!':'?':r) = mkNAGToken 5 : pgnLexer r
 pgnLexer ('!':'!':r) = mkNAGToken 3 : pgnLexer r
 pgnLexer ('!':r)     = mkNAGToken 1 : pgnLexer r
 pgnLexer ('?':'?':r) = mkNAGToken 4 : pgnLexer r
 pgnLexer ('?':'!':r) = mkNAGToken 6 : pgnLexer r
 pgnLexer ('?':r)     = mkNAGToken 2 : pgnLexer r
 pgnLexer ('%':r) = pgnLexer (dropWhile (/= '\n') r)
 pgnLexer (c:r)
       | isSpace c = pgnLexer r
       | isAlpha c || isDigit c = pgnSymbolLexer r [c]
       | otherwise = error ("Error lexing: " ++ takeWhile (/= '\n') (c:r))
 pgnLexer [] = []

 pgnSymbolLexer (c:r) sym
       | isAlpha c
       || isDigit c
       || elem c "_+#=:-/" = pgnSymbolLexer r (c:sym)
 pgnSymbolLexer r sym
       | all isDigit sym = IntToken (read (reverse sym)) : pgnLexer r
 pgnSymbolLexer r sym   = SymbolToken (reverse sym) : pgnLexer r

 readString ('\\':'\\':r) str = readString r ('\\':str)
 readString ('\\':'"':r) str = readString r ('"':str)
 readString ('"':r) str     = StringToken (reverse str) : pgnLexer r
 readString (c:r) str       = readString r (c:str)

 readComment ('}':r) str = CommentToken (revwords str []) : pgnLexer r
 readComment (c:r) str = readComment r (c:str)

 revwords (c:r) wds
    | isSpace c = revwords r wds
    | otherwise = revwords' r [c] wds
 revwords [] wds = wds
 revwords' (c:r) wd wds
    | isSpace c = revwords r (wd:wds)
    | otherwise = revwords' r (c:wd) wds
 revwords' [] wd wds = wd : wds

 readNAG (c:r) str
       | isDigit c = readNAG r (c:str)
 readNAG r str = mkNAGToken (read (reverse str)) : pgnLexer r

 mkNAGToken 1 = NAGAnnToken 1 "!"
 mkNAGToken 2 = NAGAnnToken 2 "?"
 mkNAGToken 3 = NAGAnnToken 3 "!!"
 mkNAGToken 4 = NAGAnnToken 4 "??"
 mkNAGToken 5 = NAGAnnToken 5 "!?"
 mkNAGToken 6 = NAGAnnToken 6 "?!"
 mkNAGToken n = NAGToken n

 pgnParser :: (Int -> Bool) -> String -> [AbsGame]
 pgnParser fn str =
       [ game | (no,game) <- zip [1..] (parseTags (pgnLexer str) id),
                fn no]

 type FL a = [a] -> [a]

 parseTags :: [Token] -> FL TagStr -> [AbsGame]
 parseTags (LeftSBToken:SymbolToken sym:StringToken str:RightSBToken:rest)
           other_tags = parseTags rest (other_tags . ((:) (TagStr sym str)))
 parseTags toks@(LeftSBToken:_) _
       = error ("BAD Token:" ++ unwords (map userFormat (take 10 toks)))
 parseTags toks tags = parseToks toks id tags

 parseToks :: [Token]
       -> FL Token
       -> FL TagStr
       -> [AbsGame]
 parseToks next@(LeftSBToken:_)     = \ toks tags ->
       Game (tags []) (toks []) : parseTags next id
 parseToks (tk:r)                    = pushToken tk r
 parseToks [] = \ toks tags -> [Game (tags []) (toks [])]

 pushToken tok r toks = parseToks r (toks . ((:) tok))


 module PrintTEX (texPrinter) where

 import GenUtils
 import DataTypes
 import Data.Array -- 1.3
 import Data.Char -- 1.3

 splitUpQuantum :: [Quantum] -> [[Quantum]]
 splitUpQuantum q = splitUpQuantums q []
   where
       splitUpQuantums [] [] = []
       splitUpQuantums [] mvs = [reverse mvs]
       splitUpQuantums (mv@(QuantumMove _ _ _ _):rest) mvs
               = splitUpQuantums rest (mv:mvs)
       splitUpQuantums (mv@(QuantumNAG _):rest) mvs
               = splitUpQuantums rest mvs
       splitUpQuantums (x:xs) [] = [x] : splitUpQuantums xs []
       splitUpQuantums (x:xs) mvs
               = [reverse mvs,[x]] ++ splitUpQuantums xs []

 type TeXState =
       (Bool,          -- if Top level !
       Board,          -- current board
       MoveNumber)     -- the Current Move Number

 printTeXQuantums :: TeXState -> [Quantum] -> [String]
 printTeXQuantums ps
       = concat . fst . mapAccumL printTeXQuantum ps . splitUpQuantum

 printTeXQuantum :: TeXState -> [Quantum] -> ([String],TeXState)
 printTeXQuantum state@(_,board,_) [QuantumComment ["\004"]] =
       (mkTeXBoard board,state)
 printTeXQuantum state@(_,board,_) [QuantumComment (('\004':comm):comms)] =
       (mkTeXBoard board ++ formatText 70 (parseSquiggles (comm:comms)),state)
 printTeXQuantum state [QuantumComment comms] =
       (formatText 70 (parseSquiggles comms),state)
 printTeXQuantum (pnt,brd,mv) [QuantumAnalysis anal] =
       (printTeXQuantums (False,err,decMove mv) anal,(pnt,brd,mv))
   where err = error "Syntax error using ^D"
 printTeXQuantum state@(_,board,_) [QuantumResult str] =
       (mkTeXBoard board ++ [printTeXResult (mkResult str)],state)
 printTeXQuantum state mvs@(QuantumMove _ _ _ _:_) =
       printTeXMoves state mvs
 printTeXQuantum _ _ = error "PANIC: strange Quantum"

 parseSquiggles = map parseSquiggle
 parseSquiggle ('<':'s':'a':'w':'>':r) = "\\wbetter{}" ++ r
 parseSquiggle ('<':'a':'w':'>':r)     = "\\wupperhand{}" ++ r
 parseSquiggle ('<':'w':'a':'w':'>':r) = "\\wdecisive{}" ++ r
 parseSquiggle ('<':'s':'a':'b':'>':r) = "\\bbetter{}" ++ r
 parseSquiggle ('<':'a':'b':'>':r)     = "\\bupperhand{}" ++ r
 parseSquiggle ('<':'w':'a':'b':'>':r) = "\\bdecisive{}" ++ r
 parseSquiggle wd = wd

 printTeXResult :: Result -> String
 printTeXResult Win     = "$1\\!-\\!0$"
 printTeXResult Loss    = "$0\\!-\\!1$"
 printTeXResult Draw    = "${1 \\over 2}\\!-\\!{1 \\over 2}$"
 printTeXResult Unknown = "$*$"

 printTeXMoves (tl,_,mv) mvs
       = ([text],(True,brd,incMove last_mv_num))
    where
       aux_mvs = zip3 mvs (iterate incMove mv) (False:repeat True)

       (QuantumMove _ _ _ brd,last_mv_num,_) = last aux_mvs
       text = initText tl
           ++ concat (fst (mapAccumL (pntMove tl) (mv,False) mvs))
           ++ endText tl

       initText False =
            case mv of
               MoveNumber i Black -> "|" ++ show i ++ "\\ldots~"
               _ -> "|"
       initText True =
               "\\begin{center}|\n" ++
               "{\\bf" ++
               "\\begin{tabular}{rp{50pt}p{50pt}}\n" ++
            case mv of
               MoveNumber i Black -> show i ++ " & \\ldots"
               _ -> ""

       endText True = case getMoveColour last_mv_num of
               White -> "&\\\\\n\\end{tabular}}|\n\\end{center}"
               Black -> "\\end{tabular}}|\n\\end{center}"
       endText False =  "|"

       pntMove True (mv@(MoveNumber i White),bl) move
               = (show i ++ " & "
               ++ printableMove move,
                 (incMove mv,True))
       pntMove True (mv@(MoveNumber i Black),bl) move
               = (" & " ++ printableMove move ++ "\\\\\n",
                 (incMove mv,True))
       pntMove False (mv@(MoveNumber i White),bl) move
               = ((if bl then "; " else "") ++ show i ++ ".~"
                       ++ printableMove move,
                 (incMove mv,True))
       pntMove False (mv@(MoveNumber i Black),bl) move
               = ((if bl then ", " else "") ++ printableMove move,
                 (incMove mv,True))

 printableMove :: Quantum -> String
 printableMove (QuantumMove move ch an _) = map fn move ++ rest
    where
       fn 'x' = '*'
       fn 'O' = '0'
       fn c   = c
       rest = case ch of
               "#" -> an ++ " mate"
               _   -> ch ++ an

 mkTeXBoard :: Board -> [String]
 mkTeXBoard (Board arr _ _) =
       ["\n\\board"] ++
       ["{" ++ [ fn ((x-y) `rem` 2 == 0) (arr ! (x,y)) | x <- [1..8]] ++ "}"
                       | y <- reverse [1..8]] ++
       ["$$\\showboard$$"]
  where
       fn _ (WhitesSq p) = head (userFormat p)
       fn _ (BlacksSq p) = toLower (head (userFormat p))
       fn True VacantSq = '*'
       fn False VacantSq = ' '

 printTeXGame :: RealGame -> [String]
 printTeXGame (Game tags qu) = [
       "\\clearpage",
       "\\begin{center}",
       "\\fbox{\\fbox{\\large\\begin{tabular}{l}",
       ("Game " ++ gameno ++ " \\hspace{.3 in} "
               ++ date
               ++ " \\hspace{.3 in} "
               ++ result
               ++ "\\\\"),
       "\\hline" ++ (if null opening then "" else "\n" ++ opening ++ "\\\\"),
       "\\raisebox{2.5pt}[11pt]{\\framebox[11pt]{\\rule{0pt}{4.25pt}}} "
               ++ white ++ "\\\\",
       "\\rule[-1pt]{11pt}{11pt} "++ black ++ "\\\\",
       site,
       "\\end{tabular}}}",
       "\\end{center}"] ++
       (printTeXQuantums (True,startBoard,initMoveNumber) qu)
   where
       (date,site,game_no,res,white,black,opening) = getHeaderInfo tags
       gameno = case game_no of
                 Nothing -> ""
                 Just n -> show n
       result = printTeXResult res

 texPrinter :: [RealGame] -> String
 texPrinter games =
          texHeader
       ++ (unlines(concat(map printTeXGame games)))
       ++ texFooter

 texHeader =
       "\\documentstyle[twocolumn,a4wide,chess]{article}\n" ++
       "\\textwidth 7.0 in\n" ++
       "\\textheight 63\\baselineskip\n" ++
       "\\columnsep .4 in\n" ++
       "\\columnseprule .5 pt\n" ++
       "\\topmargin -0.5 in\n" ++
       "\\headheight 0 pt\n" ++
       "\\headsep 0 pt\n" ++
       "\\oddsidemargin -0.3 in\n" ++
       "\\font\\sc=cmcsc10\n\\pagestyle{empty}\n" ++
       "\\begin{document}\n\\thispagestyle{empty}\n\n"

 texFooter = "\n\\end{document}\n"


module Basic where
import TypesettingTricks
--import Int( Num(fromInt) )
import Physical
--import GHC( (->) )
infixr 7 |>
class Signal s where
  mapSignal:: (Physical a, Physical b) => (s a b) -> a -> b
  mapSigList:: (Physical a, Physical b) => (s a b) -> [a] -> [b]
  toSig:: (Physical a, Physical b) => (s a b) -> SignalRep a b
  mapSignal = mapSignal . toSig
  mapSigList = map . mapSignal
  toSig = FunctionRep . mapSignal
instance Signal (->) where
  mapSignal f = f
  toSig = FunctionRep
data {- (Physical a, Physical b) => -} SignalRep a b =
   FunctionRep (a -> b) |
   PieceContRep (PieceCont a b)

instance Eq (SignalRep a b) where
  (==) a b = error "No equality for SignalRep"

instance Show (SignalRep a b) where
  show sr = error "No show for SignalRep"

instance Signal SignalRep where
  mapSignal (FunctionRep f) = mapSignal f
  mapSignal (PieceContRep f) = mapSignal f
  mapSigList (FunctionRep f) = mapSigList f
  mapSigList (PieceContRep f) = mapSigList f
  toSig = id
instance (Physical a, Physical b) => Eq (a -> b) where
  a == b = error "Attempt to apply equality to functions"
binop:: (Physical a, Physical b) => (Float -> Float -> Float) ->
                                    (a -> b) -> (a -> b) -> a -> b
binop op f g t = toPhysical ((fromPhysical (f t)) `op` (fromPhysical (g t)))
unop:: (Physical a, Physical b ) => (Float -> Float) ->
                                    (a -> b) -> a -> b
unop op f t = toPhysical (op (fromPhysical (f t)))
instance (Physical a, Physical b) => Num (SignalRep a b) where
  f + g = FunctionRep (binop (+) (mapSignal f) (mapSignal g))
  f * g = FunctionRep (binop (*) (mapSignal f) (mapSignal g))
  negate f = FunctionRep (unop negate (mapSignal f))
  abs f = FunctionRep (unop abs (mapSignal f))
  signum f = FunctionRep (unop abs (mapSignal f))
  fromInteger i = FunctionRep (\t -> toPhysical (fromInteger i))
  --fromInt i = FunctionRep (\t -> toPhysical (fromInt i))
instance (Physical a, Physical b) =>
         Fractional (SignalRep a b) where
  f / g = FunctionRep (binop (/) (mapSignal f) (mapSignal g))
  fromRational r = FunctionRep (\t -> (toPhysical (fromRational r)))
instance (Physical a, Physical b) =>
          Floating (SignalRep a b) where
  pi = FunctionRep (\t -> (toPhysical pi))
  exp   f = FunctionRep (unop exp (mapSignal f))
  log   f = FunctionRep (unop log (mapSignal f))
  sin   f = FunctionRep (unop sin (mapSignal f))
  cos   f = FunctionRep (unop cos (mapSignal f))
  asin  f = FunctionRep (unop asin (mapSignal f))
  acos  f = FunctionRep (unop acos (mapSignal f))
  atan  f = FunctionRep (unop atan (mapSignal f))
  sinh  f = FunctionRep (unop sinh (mapSignal f))
  cosh  f = FunctionRep (unop cosh (mapSignal f))
  asinh f = FunctionRep (unop asinh (mapSignal f))
  acosh f = FunctionRep (unop acosh (mapSignal f))
  atanh f = FunctionRep (unop atanh (mapSignal f))
data Event =
  TimeEvent Float |
  FunctionEvent (Float -> Bool) |
  BurstEvent Int Event

instance Show Event where
  show (TimeEvent f) = "TimeEvent " ++ show f
  show (FunctionEvent _) = "FunctionEvent"
  show (BurstEvent i e)  = "BurstEvent " ++ show i ++ " " ++ show e

instance Eq Event where
  (TimeEvent x) == (TimeEvent y) = x == y
  (BurstEvent i e) == (BurstEvent i' e') = (i' == i) && (e' == e)
eventOccurs:: Event -> Float -> Float
eventOccurs (TimeEvent t) x = if x < t then x else t
eventOccurs (FunctionEvent f) x = stepEval f x
eventOccurs (BurstEvent i e) x =
          if i == 1 then
            eventOccurs e x
          else
            eventOccurs (BurstEvent (i-1) e) ((eventOccurs e x) + eventEps x)
stepEval:: (Float -> Bool) -> Float -> Float
stepEval f x = if f x then x else stepEval f (x + eventEps x)
data ZeroIndicator = LocalZero | GlobalZero deriving (Eq, Show)
data {- (Physical a, Physical b) => -} FunctionWindow a b =
     Window ZeroIndicator Event (SignalRep a b)
     deriving (Eq, Show)
data PieceCont a b = Windows [FunctionWindow a b]
     deriving (Eq, Show)
instance Signal PieceCont where
  mapSignal (Windows []) t = toPhysical 0.0
  mapSignal (Windows wl) t = (mapSignal s) (toPhysical t')
      where (t', (Window z e s), wl') = getWindow 0.0 (fromPhysical t) wl
  toSig = PieceContRep
getWindow:: (Physical a, Physical b) =>
            Float -> Float -> [ FunctionWindow a b ] ->
            (Float, FunctionWindow a b, [ FunctionWindow a b ])
getWindow st t [] = (t, Window LocalZero e f, [])
                    where e = TimeEvent (realmul 2 t)
                          f = FunctionRep (\t -> toPhysical 0.0)
getWindow st t (w:wl) = if t' <= wt then (t',w,w:wl)
                        else getWindow (st+wt) t wl
    where wt = eventOccurs e t'
          (Window z e s) = w
          t' = if z == LocalZero then t-st else t
(|>) :: (Physical a, Physical b) => FunctionWindow a b ->
        PieceCont a b -> PieceCont a b
w |> (Windows wl) = Windows (w:wl)
nullWindow = Windows []
cycleWindows:: (Physical a, Physical b) =>
                PieceCont a b -> PieceCont a b
cycleWindows (Windows wl) = Windows (cycle wl)
constant:: (Physical a, Physical b) => b -> SignalRep a b
constant x = FunctionRep (\t -> x)
linear:: (Physical a, Physical b) => Float -> b -> SignalRep a b
linear m b  = FunctionRep (\x -> toPhysical (realmul m (fromPhysical x) + (fromPhysical b)))
sine:: (Physical a, Physical b) =>
       b -> Frequency -> Float -> SignalRep a b
sine mag omeg phase = FunctionRep (\x -> toPhysical (realmul (fromPhysical mag) (sin (realmul (realmul (realmul 2 pi) (fromPhysical omeg)) (fromPhysical x) + phase))))
waveform:: (Physical a, Physical b) => a -> [b] -> SignalRep a b
waveform samp ampls =
  let stepSlope y y' = realdiv ((fromPhysical y') - (fromPhysical y)) (fromPhysical samp)
      makeWin (v,v') = Window LocalZero (TimeEvent (fromPhysical samp))
                       (linear (stepSlope v v') v)
      points = cycle ampls
  in PieceContRep (Windows (map makeWin (zip points (tail points))))
random:: (Physical a, Physical b) =>
         Integer -> a -> SignalRep a b
random i s = waveform s (map toPhysical (rand i))
ramp:: (Physical a, Physical b) => a -> b -> SignalRep a b
ramp per v =
  let sig = linear (realdiv (fromPhysical v) (fromPhysical per)) (toPhysical 0.0)
  in PieceContRep (Windows (cycle ([Window LocalZero (TimeEvent (fromPhysical per)) sig ])))
triangle:: (Physical a, Physical b) => a -> b -> SignalRep a b
triangle per v =
  let sl = realmul 2.0 (realdiv (fromPhysical v) (fromPhysical per))
      qper = realdiv (fromPhysical v) 4.0
      wins =  (Window LocalZero (TimeEvent qper) (linear sl (toPhysical 0.0))) |>
              (Window LocalZero (TimeEvent (realmul 2.0 qper)) (linear (- sl) v)) |>
              (Window LocalZero (TimeEvent qper) (linear sl (toPhysical (- (fromPhysical v))))) |>
               nullWindow
  in PieceContRep (cycleWindows wins)
step:: (Physical a, Physical b) => a -> b -> SignalRep a b
step tr lvl = FunctionRep (\t -> if (fromPhysical t) < (fromPhysical tr) then (toPhysical 0.0) else lvl)
square:: (Physical a, Physical b) => a -> b -> SignalRep a b
square per lvl =
  let trans = realdiv (fromPhysical per) 2.0
      nlvl = asTypeOf (toPhysical (- (fromPhysical lvl))) lvl
      f t = if (fromPhysical t) < trans then lvl else nlvl
      wins = Windows [Window LocalZero (TimeEvent (fromPhysical per)) (FunctionRep f)]
  in PieceContRep (cycleWindows wins)
pulse:: (Physical a, Physical b) => a -> a -> b -> SignalRep a b
pulse st wid lvl =
  let tr = (fromPhysical st) + (fromPhysical wid)
      f t = if (fromPhysical t) < (fromPhysical st) then (toPhysical 0.0)
            else if (fromPhysical t) < tr then lvl else (toPhysical 0.0)
  in FunctionRep f
trap:: (Physical a, Physical b) => a -> a -> a -> a -> b ->
                                   SignalRep a b
trap st r wid f lvl =
  let stepSlope y y' t = realdiv (y' -  y) (fromPhysical t)
      bigwin = realmul 10000000 ((fromPhysical st) + (fromPhysical wid))
      wins = Window LocalZero (TimeEvent (fromPhysical st)) (constant (toPhysical 0.0)) |>
             Window LocalZero (TimeEvent (fromPhysical r)) (linear (stepSlope 0.0 (fromPhysical lvl) r) (toPhysical 0.0)) |>
             Window LocalZero (TimeEvent (fromPhysical wid)) (constant lvl) |>
             Window LocalZero (TimeEvent (fromPhysical f)) (linear (stepSlope (fromPhysical lvl) 0.0 f) lvl) |>
             Window LocalZero (TimeEvent bigwin) (constant (toPhysical 0.0)) |>
             nullWindow
  in PieceContRep wins
expc:: (Physical a, Physical b) => Float -> SignalRep a b
expc damp = FunctionRep (\t -> toPhysical (exp (- (realmul (fromPhysical t) damp))))
data {- (Physical indep, Physical dep) => -} BasicSignal indep dep =
    Overshoot {start_delay::indep,
               pulse_width::indep,
               ringing::dep,
               oscillation::Frequency,
               damp_fac::Float}
  | Pulse_dc {start_delay::indep,
              pulse_width::indep,
              rise_time::indep,
              fall_time::indep,
              period::indep,
              dc_offset::dep,
              amplitude::dep,
              over::BasicSignal indep dep,
              under::BasicSignal indep dep}
  | Pulse_ac {start_delay::indep,
              pulse_width::indep,
              period::indep,
              dc_offset::dep,
              amplitude::dep,
              frequency::Frequency,
              phase::Float}
  deriving (Eq, Show)

data {- (Eq a, Eq b) => -} Foo a b = Foo { x :: a, y :: b}

foo :: (Eq a, Eq b) => Foo a b
foo = Foo{}

{-
overshoot:: (Physical a, Physical b) => BasicSignal a b
overshoot = Overshoot{}
pulse_dc:: (Physical a, Physical b) => BasicSignal a b
pulse_dc = Pulse_dc {over = Overshoot{start_delay=toPhysical 0.0,
                                            ringing=(toPhysical 0.0),
                                            oscillation=toPhysical 1.0,
                                            damp_fac=1.0},
                     under = Overshoot{start_delay=toPhysical 0.0,
                                             ringing=(toPhysical 0.0),
                                             oscillation=toPhysical 1.0,
                                             damp_fac=1.0},
                     start_delay = toPhysical 0.0,
                     dc_offset = toPhysical 0.0}

pulse_ac:: (Physical a, Physical b) => BasicSignal a b
pulse_ac = Pulse_ac {dc_offset = toPhysical 0.0,
                     amplitude = toPhysical 0.0}
-}

makeWin:: (Physical a, Physical b) => a -> a ->
           SignalRep a b -> SignalRep a b
makeWin st wid sig =
  let wins = Window LocalZero (TimeEvent (fromPhysical st)) (constant (toPhysical 0.0)) |>
             Window LocalZero (TimeEvent (fromPhysical wid)) sig |>
             nullWindow
  in PieceContRep wins
instance Signal BasicSignal where
  toSig (Overshoot start_delay pulse_width ringing oscillation damp_fac) =
    let ring = sine ringing oscillation 0.0
        cond = asTypeOf (expc damp_fac) ring
        sig = temp ring cond
        temp:: (Physical a, Physical b) => SignalRep a b ->
                SignalRep a b -> SignalRep a b
        temp f g = FunctionRep (binop (*) (mapSignal f) (mapSignal g))
--        temp f g = f * g
--        temp f g = asTypeOf (f * g) ring
        wins = Window LocalZero (TimeEvent (fromPhysical start_delay)) (constant (toPhysical 0.0)) |>
               Window LocalZero (TimeEvent (fromPhysical pulse_width)) sig |>
               nullWindow
    in PieceContRep wins
  toSig Pulse_dc{ start_delay = start_delay
                , rise_time   = rise_time
                , pulse_width = pulse_width
                , fall_time   = fall_time
                , dc_offset   = dc_offset
                , period      = period
                , amplitude   = amplitude
                , over        = over
                , under       = under
                } =
    let pul = trap start_delay rise_time pulse_width fall_time amplitude
        so = toPhysical ((fromPhysical start_delay) + (fromPhysical rise_time))
        su = toPhysical ((fromPhysical so) + (fromPhysical pulse_width) + (fromPhysical fall_time))
        oversh = toSig over{start_delay=so}
        undersh = toSig under{start_delay=su}
        off = constant dc_offset
        temp:: (Physical a, Physical b) => SignalRep a b ->
                SignalRep a b -> SignalRep a b
        temp f g = FunctionRep (binop (+) (mapSignal f) (mapSignal g))
        sig = temp (temp (temp pul oversh) undersh) off
        wins = (Window LocalZero (TimeEvent (fromPhysical period)) sig) |>
                nullWindow
    in PieceContRep (cycleWindows wins)
sumSig:: (Physical a, Physical b, Signal s, Signal s') =>
         (s a b) -> (s' a b) -> SignalRep a b
sumSig f f' =
   let s1 t = fromPhysical (mapSignal f t)
       s2 t = fromPhysical (mapSignal f' t)
   in FunctionRep (\t -> toPhysical ((s1 t) + (s2 t)))
mulSig:: (Physical a, Physical b, Signal s, Signal s') =>
         (s a b) -> (s' a b) -> SignalRep a b
mulSig f f' =
   let f1 t = fromPhysical (mapSignal f t)
       f2 t = fromPhysical (mapSignal f' t)
   in FunctionRep (\t -> toPhysical ((f1 t) * (f2 t)))

eventEps:: Float -> Float
eventEps x = let eps = realdiv x 1000 in if 0.01 < eps then 0.01 else eps


module Bug where

data Eq a => Foo a = Foo { x :: a }

foo :: Foo Int
foo = Foo{}


module Main where
import Physical
import Basic
import TypesettingTricks
import PlotExample
import Expected
sinExample:: SignalRep Time Voltage
sinExample = sine (V 2.0) (Hz 10) 0.0
sinPlot = plotExample "sine" sinExpected sinExample 0.0 1.0
pieceExample = toSig Pulse_dc
  { start_delay=(Sec 1.0),
    rise_time=(Sec 0.2),
    pulse_width=(Sec 3.0),
    fall_time=(Sec 0.3),
    dc_offset=(V (- 1.0)),
    period=(Sec 10.0),
    amplitude=(V 5.0),
    over=Overshoot{ringing=(V 0.2),
                   pulse_width=(Sec 3.0),
                   oscillation=(Hz 2.0),
                   damp_fac=1.0},
    under=Overshoot{ringing=(V (- 0.25)),
                    pulse_width=(Sec 3.0),
                    oscillation=(Hz 2.10),
                    damp_fac=1.10} }
piecePlot = plotExample "piece" pieceExpected pieceExample 0.0 20.0
main = putStrLn (sinPlot ++ piecePlot)