module HRDsolver 
  ( Donkey, Square, Horiz, Vertic
  , ToLeft, ToRight, ToUp, ToDown 
  , getPiece, appMove, solveHRD
  , donkey, squares, horiz, vertics
  , start, okStatus
  ) where

import Trace

---------------------------------------------------------
--                                                     --
-- data structures and functions for the game settings --
--                                                     --
---------------------------------------------------------

-- Cell : an integer label of the cells
type Cell = Int

-- up, left, down, right : move around the board
up, left, down, right :: Cell -> Cell
up n    = n - 10
left n  = n - 1
down n  = n + 10
right n = n + 1

-- up2, left2, down2, right2 : move two cells around the board
up2, left2, down2, right2 :: Cell -> Cell
up2 n    = n - 20
left2 n  = n - 2
down2 n  = n + 20
right2 n = n + 2

-- Piece : the playing pieces
data Piece 
  = Donkey
  | Square
  | Horiz
  | Vertic
  | None
  deriving Show

-- Board : the configurations of the board
data Board
  = Board
      { donkey :: Cell
      , squares :: [Cell]
      , horiz :: Cell
      , vertics :: [Cell]
      }
  deriving Show

-- Config : the configuration of the board
--          the pair of integers represent the two free squares;
--          this infomation is redundant, but it will make the computation
--          more efficient
type Config = ((Cell, Cell), Board)

-- start : the initial configuration(s)
start, start1, startSt1, startSt2 :: Config
-- start1 : easy opening (47 steps) (201 status)
start1   = ( (31, 34)
           , Board
               { donkey = 12
               , squares = [11, 14, 21, 24]
               , horiz = 32
               , vertics = [41, 42, 43, 44]
               }
           ) 
-- startSt1 : standard opening (111 steps) (1'20", 58 steps, 750 status halt)
startSt1 = ( (31, 34)
           , Board
               { donkey = 12
               , squares = [42, 43, 52, 53]
               , horiz = 32
               , vertics = [11, 14, 41, 44]
               }
           ) 
-- startSt2 : standard opening (111 steps) (1'20", 58 steps, 750 status halt)
startSt2 = ( (33, 34)
           , Board
               { donkey = 43
               , squares = [23, 24, 51, 52]
               , horiz = 13
               , vertics = [11, 12, 31, 32]
               }
           ) 
start = start1

-- Direction : the direction that the piece moves toward
data Direction = ToLeft | ToUp | ToRight | ToDown
  deriving Show

-- Move : the integer indicates the sqaure which is free before the move
--        and be occupied afterwards, or in the case where two sqaures are
--        used by the move, it indicates the higher and leftmost of the two
type Move = (Int, Direction)

-- getPiece : test whether a given square is occupied or not by the upper
--            left corner of a piece; if it is, return the name of the piece 
getPiece :: Cell -> Board -> Piece
getPiece cell board
  = if donkey board == cell then Donkey else
    if horiz board == cell then Horiz else
    if elem cell (squares board) then Square else
    if elem cell (vertics board) then Vertic
    else None     

-- movesOne : compute all the possible moves that need only one square
--            notice the pieces are indicated by the *upper left* corner
movesOne :: Cell -> Board -> [Move]
movesOne b board
  = (leftMove (getPiece (right b) board)) ++
    (upMove (getPiece (down b) board)) ++
    (rightMove (getPiece (left b) board) (getPiece (left (left b)) board)) ++
    (downMove (getPiece (up b) board) (getPiece (up (up b)) board))
  where
    leftMove, upMove :: Piece -> [Move]
    leftMove Square = [(b, ToLeft)]
    leftMove Horiz  = [(b, ToLeft)]
    leftMove _      = []
    upMove Square   = [(b, ToUp)]
    upMove Vertic   = [(b, ToUp)]
    upMove _        = []
    rightMove, downMove :: Piece -> Piece -> [Move]
    rightMove p1 p2 = case (p1, p2) of
                        (Square, _) -> [(b, ToRight)] 
                        (_, Horiz)  -> [(b, ToRight)]
                        _           -> []
    downMove p1 p2  = case (p1, p2) of
                        (Square, _) -> [(b, ToDown)]
                        (_, Vertic) -> [(b, ToDown)]
                        _           -> []

-- hAdjacent : test whether two squares are adjacent horizontally
hAdjacent :: Cell -> Cell -> Bool
hAdjacent n1 n2 = n2 == n1 + 1

-- vAdjacent : test whether two squares are adjacent vertically
vAdjacent :: Cell -> Cell -> Bool
vAdjacent n1 n2 = n2 == n1 + 10

-- movesTwo : compute all the possible moves that need two squares
--            notice the pieces are indicated by the *upper left* corner
movesTwo :: (Cell, Cell) -> Board -> [Move]
movesTwo (b1, b2) board
  = if not(hAdjacent b1 b2) && not(vAdjacent b1 b2) then [] else
    if hAdjacent b1 b2 then
      (upMove (getPiece (down b1) board)) ++
      (downMove (getPiece (up b1) board) (getPiece (up (up b1)) board))
    else
      (leftMove (getPiece (right b1) board)) ++
      (rightMove (getPiece (left b1) board) (getPiece (left (left b1)) board))
  where
    leftMove, upMove :: Piece -> [Move]
    leftMove Donkey = [(b1, ToLeft)]
    leftMove Vertic = [(b1, ToLeft)]
    leftMove _      = []
    upMove Donkey   = [(b1, ToUp)]
    upMove Horiz    = [(b1, ToUp)]
    upMove _        = []
    rightMove, downMove :: Piece -> Piece -> [Move]
    rightMove p1 p2 = case (p1, p2) of
                        (_, Donkey) -> [(b1, ToRight)] 
                        (Vertic, _) -> [(b1, ToRight)]
                        _           -> []
    downMove p1 p2  = case (p1, p2) of
                        (_, Donkey) -> [(b1, ToDown)]
                        (Horiz, _)  -> [(b1, ToDown)]
                        _           -> []

-- CompactBoard : the compact representation of configurations for storage
--                we use several bits to indicate the position of a piece
--                for details :
--                  donkey       : 11 - 43, 12 positions, 4 bits
--                  horiz        : 11 - 53, 15 positions, 4 bits
--                  sqaures (x4) : 11 - 54, 20 positions, 5 bits
--                  vertics (x4) : 11 - 44, 16 positions, 4 bits
--                we use a pair of Int to denote the code, where the 1st
--                Int for d, h, and s (28 bits); the 2nd Int for v (16 bits) 
type CompactBoard = (Int, Int) 

-- translateN2C : translate position of piece into compact bits
translateN2C :: Cell -> Int -> Int
translateN2C n base = (n `div` 10 - 1) * base + (n `mod` 10 - 1)

-- translateL2C : translate positions of pieces into compact bits
translateL2C :: [Cell] -> Int -> Int -> Int
translateL2C [] _ _ = 0
translateL2C (h : t) base offset
  = (translateN2C h base) * 2 ^ ((length t) * offset)
      + translateL2C t base offset

-- boardN2C : board mode translation (normal -> compact)
boardN2C :: Board -> CompactBoard
boardN2C board
  = (donkeyNum * 2 ^ 24 + horizNum * 2 ^ 20 + sqauresNum, verticsNum)
    where  
      donkeyNum  = translateN2C (donkey board) 3
      horizNum   = translateN2C (horiz board) 3
      sqauresNum = translateL2C (squares board) 4 5
      verticsNum = translateL2C (vertics board) 4 4

-- translateC2N : translate compact bits into position of piece
translateC2N :: Int -> Int -> Cell
translateC2N base c
  = (c `div` base + 1) * 10 + (c `mod` base + 1)

-- translateC2L : translate compact bits into positions of pieces
translateC2L :: Int -> Int -> Int -> Int -> [Cell]
translateC2L base num offset c
  | num <= 1
    = [translateC2N base c]
  | num > 1
    = (translateC2N base (c `div` 2 ^ ((num - 1) * offset)))
    : (translateC2L base (num - 1) offset
         (c `mod` 2 ^ ((num - 1) * offset)))

-- boardC2N : board mode translation (compact -> normal)
boardC2N :: CompactBoard -> Board
boardC2N (cBoard1, cBoard2)
  = Board
      (getDonkey (cBoard1 `div` (2 ^ 24)))
      (getSqaures (cBoard1 `mod` (2 ^ 20)))
      (getHoriz (cBoard1 `div` (2 ^ 20) `mod` (2 ^ 4)))
      (getVertics cBoard2)
    where
      getDonkey  = translateC2N 3
      getHoriz   = translateC2N 3
      getSqaures = translateC2L 4 4 5
      getVertics = translateC2L 4 4 4

-- CompactConfig : compact representationof configuration
--                 the pos of two empty squares are store at the 2nd Int
--                 of the 2nd Int of CompactBoard (17-21, 22-26)
type CompactConfig = (Int, Int)

-- configN2C : board mode translation (normal -> compact)
configN2C :: Config -> CompactConfig
configN2C ((b1, b2), board)
  = (c1, emptyNum1 * 2 ^ 21 + emptyNum2 * 2 ^ 16 + c2)
    where
      emptyNum1 = translateN2C b1 4
      emptyNum2 = translateN2C b2 4
      (c1, c2) = boardN2C board

-- configC2N : config mode translation (compact -> normal)
configC2N :: CompactConfig -> Config
configC2N (c1, c2)
  = ( ( getEmpty (c2 `div` (2 ^ 21))
      , getEmpty (c2 `div` (2 ^ 16) `mod` (2 ^ 5))
      )
    , boardC2N (c1, c2 `mod` (2 ^ 16))
    )
    where
      getEmpty = translateC2N 4 

-- cellComp : compare two cells, i.e. compare two integers
cellComp :: Cell -> Cell -> Ordering
cellComp = compare

{-
-- cellListComp : compare two cell lists
cellListComp :: [Cell] -> [Cell] -> Ordering
cellListComp [] [] = EQ
cellListComp (c1 : ct1) (c2 : ct2)
  = case cellComp c1 c2 of
      LT -> LT
      GT -> GT
      EQ -> cellListComp ct1 ct2

-- boardComp : compare two boards
boardComp :: Board -> Board -> Ordering
boardComp b1 b2
  = case cellComp (donkey b1) (donkey b2) of
      LT -> LT
      GT -> GT
      EQ -> case cellComp (horiz b1) (horiz b2) of
              LT -> LT
              GT -> GT
              EQ -> case cellListComp (squares b1) (squares b2) of
                      LT -> LT
                      GT -> GT
                      EQ -> case cellListComp (vertics b1) (vertics b2) of
                              LT -> LT
                              GT -> GT
                              EQ -> EQ
-}

-- boardComp : compare two boards
boardComp :: CompactBoard -> CompactBoard -> Ordering
boardComp (cb11, cb12) (cb21, cb22)
  = case compare cb11 cb21 of
      LT -> LT
      GT -> GT
      EQ -> compare cb12 cb22

-- appMove : apply a move to a configuration
appMove :: Config -> Move -> Config
appMove ((b1, b2), board) (b, d)
  = case d of
      ToLeft ->
        case getPiece (right b) board of
          Square -> ( updatePair b (right b) (b1, b2)
                    , updateSquare board
                        (sort cellComp
                           (update (right b) b (squares board)))
                    )
          Horiz  -> ( updatePair b (right (right b)) (b1, b2)
                    , updateHoriz board b
                    )
          Donkey -> ( (right (right b1) , right (right b2))
                    , updateDonkey board b
                    )
          Vertic -> ( (right b1, right b2)
                    , updateVertic board
                        (sort cellComp
                           (update (right b) b (vertics board)))
                    )
          _      -> ( (b1, b2), board )     -- wrong move
      ToRight ->
        case (getPiece (left b) board, getPiece (left (left b)) board) of
          (Square, _) -> ( updatePair b (left b) (b1, b2)
                         , updateSquare board
                             (sort cellComp
                                (update (left b) b (squares board)))
                         )
          (_, Horiz)  -> ( updatePair b (left (left b)) (b1, b2)
                         , updateHoriz board (left b)
                         )
          (_, Donkey) -> ( (left (left b1) , left (left b2))
                         , updateDonkey board (left b)
                         )
          (Vertic, _) -> ( (left b1, left b2)
                         , updateVertic board
                             (sort cellComp
                                (update (left b) b (vertics board)))
                    )
          _           -> ( (b1, b2), board )     -- wrong move
      ToUp ->
        case getPiece (down b) board of
          Square -> ( updatePair b (down b) (b1, b2)
                    , updateSquare board
                        (sort cellComp
                           (update (down b) b (squares board)))
                    )
          Horiz  -> ( (down b1, down b2)
                    , updateHoriz board b
                    )
          Donkey -> ( (down (down b1) , down (down b2))
                    , updateDonkey board b
                    )
          Vertic -> ( updatePair b (down (down b)) (b1, b2)
                    , updateVertic board
                        (sort cellComp
                           (update (down b) b (vertics board)))
                    )
          _      -> ( (b1, b2), board )     -- wrong move
      ToDown ->
        case (getPiece (up b) board, getPiece (up (up b)) board) of
          (Square, _) -> ( updatePair b (up b) (b1, b2)
                         , updateSquare board
                             (sort cellComp
                                (update (up b) b (squares board)))
                         )
          (Horiz, _)  -> ( (up b1, up b2)
                         , updateHoriz board b
                         )
          (_, Donkey) -> ( (up (up b1) , up (up b2))
                         , updateDonkey board (up b)
                         )
          (_, Vertic) -> ( updatePair b (up (up b)) (b1, b2)
                         , updateVertic board
                             (sort cellComp
                                (update (up (up b)) (up b) (vertics board)))
                         )
          _           -> ( (b1, b2), board )     -- wrong move
    where
      -- orderPair : order the two empty sqaures
      orderPair :: (Cell, Cell) -> (Cell, Cell)
      orderPair (n1, n2)
        = case cellComp n1 n2 of
            LT -> (n1, n2)
            EQ   -> (n1, n2)
            GT -> (n2, n1)
      -- updatePair : update the two empty sqaures
      updatePair :: Cell -> Cell -> (Cell, Cell) -> (Cell, Cell)
      updatePair x y (l, r) | x == l = orderPair (y, r)
                            | x /= l = orderPair (l, y)
      -- updateDonkey(Square/Horiz/Vertic) : update the board
      updateDonkey, updateHoriz :: Board -> Int -> Board
      updateSquare, updateVertic :: Board -> [Int] -> Board  
      updateDonkey board x
        = Board x (squares board) (horiz board) (vertics board) 
      updateSquare board x
        = Board (donkey board) x (horiz board) (vertics board)
      updateHoriz board x
        = Board (donkey board) (squares board) x (vertics board)
      updateVertic board x
        = Board (donkey board) (squares board) (horiz board) x

-- appMoves : apply a move sequence to a cofiguration
-- appMoves :: Config -> [Move] -> Config
-- appMoves c ml = foldl appMove c ml 

-- Status : the moving history and the current configuration it leads to
type Status = ([Move], CompactConfig)

-- nextStatuses : the statuses we can reach from a given status
nextStatuses :: Status -> [Status]
nextStatuses (ml, cc)
  = map (\m -> (m : ml, configN2C (appMove ((b1, b2), board) m))) moves
      where
        ((b1, b2), board) = configC2N cc
        moves :: [Move]  
        moves = (movesOne b1 board) ++
                (movesOne b2 board) ++
                (movesTwo (b1, b2) board)

------------------------------------------------------------
--                                                        --
-- data structures and functions for breadth-first-search --
--                                                        --
------------------------------------------------------------

o :: (a -> b) -> (c -> a) -> c -> b
o f g = \x -> f (g x)

-- loop : test whether given property will be satisfied after applied some
--        function on the initial value for some times
loop :: (a -> Bool) -> (a -> a) -> a -> a
loop p f x = if p x then x else loop p f (f x)

-- loopn : similar to loop, print the number of iterations for debugging
loopn :: Int -> (a -> Bool) -> (a -> a) -> a -> a
loopn n p f x
  = if p x then x
    else loopn (trace (show (n - 1) ++ "\n") (n - 1)) p f (f x)

-- find : find the first element satisfying given property in a list 
find :: (a -> Bool) -> [a] -> a
find p [] = error "list find failure"
find p (h : t) = if p h then h else find p t

-- select : select all elements satisfying given property in a list
select :: (a -> Bool) -> [a] -> [a]
select p [] = []
select p (h : t) = if p h then h : (select p t) else select p t

-- solveBreadthFirst : breadth first search
solveBreadthFirst ::
  (a -> Bool, a -> [a], b -> b -> Ordering) -> (a -> b) -> [a] -> a
solveBreadthFirst (ok, posMoves, comp) archPart startStatus
  = (find ok `o` snd)
      (loop
         (any ok `o` snd)
         (archiveMap archPart posMoves)
         (makeArchive comp (map archPart startStatus), startStatus)
      )

-- solveBreadthFirstTrace : BFS with trace for debugging
solveBreadthFirstTrace ::
  (a -> Bool, a -> [a], b -> b -> Ordering) -> (a -> b) -> [a] -> a
solveBreadthFirstTrace (ok, posMoves, comp) archPart startStatus
  = (find ok `o` snd)
      (loopn
         0
         (any ok `o` snd)
         (archiveMap archPart posMoves)
         (makeArchive comp (map archPart startStatus), startStatus)
      )

-- solveHRD : search for the optimal solution of the HRD game,
--            start is the initial status and ok denotes the solution
solveHRD :: Config -> (Status -> Bool) -> Status
solveHRD start ok
  = solveBreadthFirst
      (ok, nextStatuses, boardComp)
      snd
      [([], configN2C start)]

-- solveHRDTrace : solver with trace for debugging
solveHRDTrace :: Config -> (Status -> Bool) -> Status
solveHRDTrace start ok
  = solveBreadthFirstTrace
      (ok, nextStatuses, boardComp)
      snd
      [([], configN2C start)]

okStatus :: Status -> Bool
okStatus s = -- (donkey (snd (snd s))) == 42 
             (fst (snd s)) `div` (2 ^ 24) == 10 


-------------------------------------------
--                                       --
-- basic tree, archive and list fuctions --
--                                       --
-------------------------------------------

-- BTree : binary tree
data BTree a
  = Empty
  | Bin (BTree a) a (BTree a)
  deriving Show

-- Balance : the possible balancing statuses for an AVL tree
data Balance
  = BLeft
  | Balanced
  | BRight
  deriving Show

-- root : access the root of a BST 
-- root :: BTree a -> a
-- root Empty = error "root : empty tree"
-- root (Bin _ a _) = a

-- searchBst : find an element in a (sub)BST
searchBst :: (a -> b -> Ordering) -> a -> BTree b -> Bool
searchBst order e
  = search
      where
        search Empty = False
        search (Bin t1 x t2)
          = case order e x of
              EQ -> True
              LT -> search t1
              GT -> search t2

-- findBst : find an element in a BST (from the root node)
-- findBst :: (a -> b -> Ordering) -> a -> BTree b -> b
-- findBst order = searchBst order root

-- belongsToBst : test whether an element belongs to a BST
belongsToBst :: (a -> b -> Ordering) -> a -> BTree b -> Bool
belongsToBst order e t = searchBst order e t

-- AvlTree : AVL tree is a balanced binary search tree
type AvlTree a
  = BTree (a, Balance)

-- AvlAddInfo : indicate the balance information
--              NoInc means the height has not changed
--              IncLeft is used when the height increases on the left
--              IncRight is used when the height increases on the right
data AvlAddInfo
  = NoInc
  | IncLeft
  | IncRight
  deriving (Eq, Show)

-- belongsToAvl : test whether a value belongs to an AVL tree
belongsToAvl :: (a -> b -> Ordering) -> a -> BTree (b, c) -> Bool
belongsToAvl order
  = belongsToBst (\x -> \y -> order x (fst y))

-- addToAvl : add an element to an AVL tree
addToAvl :: (a -> a -> a) -> (a -> a -> Ordering) ->
              BTree (a, Balance) -> a -> BTree (a, Balance)
addToAvl option order t e
  = fst (add t)
      where
        add Empty = ((Bin Empty (e, Balanced) Empty), IncLeft) 
        add (Bin t1 (x, b) t2)
          = case (order e x, b) of
              (EQ, _)     ->
                ((Bin t1 (option e x, b) t2), NoInc)
              (LT, Balanced) ->
                let (t, m) = add t1
                 in if m == NoInc then ((Bin t (x, Balanced) t2), NoInc)
                    else ((Bin t (x, BLeft) t2), IncLeft)
              (GT, Balanced) ->
                let (t, m) = add t2
                 in if m == NoInc then ((Bin t1 (x, Balanced) t), NoInc)
                    else ((Bin t1 (x, BRight) t), IncRight)
              (GT, BLeft)     ->
                let (t, m) = add t2
                 in if m == NoInc then ((Bin t1 (x, BLeft) t), NoInc)
                    else ((Bin t1 (x, Balanced) t), NoInc)
              (LT, BLeft)     ->
                let (t, m) = add t1
                 in case m of
                      NoInc      ->
                        ((Bin t (x, BLeft) t2), NoInc)
                      IncLeft    ->
                        (rotRight (Bin t (x, Balanced) t2), NoInc)
                      IncRight   ->
                        (rotLeftRight (Bin t (x, Balanced) t2), NoInc)
              (LT, BRight)    ->
                let (t, m) = add t1
                 in if m == NoInc then ((Bin t (x, BRight) t2), NoInc)
                    else ((Bin t (x, Balanced) t2), NoInc)
              (GT, BRight)    ->
                let (t, m) = add t2
                 in case m of
                      NoInc      ->
                        ((Bin t1 (x, BRight) t), NoInc)
                      IncLeft    ->
                        (rotRightLeft (Bin t1 (x, Balanced) t), NoInc)
                      IncRight   ->
                        (rotLeft (Bin t1 (x, Balanced) t), NoInc)
        rotRight :: BTree (a, Balance) -> BTree (a, Balance)
        rotRight (Bin (Bin u (p, b) v) (q, _) w)
          = case b of
              Balanced -> Bin u (p, BRight) (Bin v (q, BLeft) w)
              BLeft    -> Bin u (p, Balanced) (Bin v (q, Balanced) w)
              BRight   -> error "rotRight error"
        rotRight _ = error "rotRight error"
        rotLeft :: BTree (a, Balance) -> BTree (a, Balance)
        rotLeft (Bin u (p, _) (Bin v (q, b) w))
          = case b of
              Balanced -> Bin (Bin u (p, BRight) v) (q, BLeft) w
              BRight   -> Bin (Bin u (p, Balanced) v) (q, Balanced) w
              BLeft    -> error "rotLeft error"
        rotLeft _ = error "rotLeft error"
        rotLeftRight :: BTree (a, Balance) -> BTree (a, Balance)
        rotLeftRight (Bin (Bin t (p, _) (Bin u (q, b) v)) (r, _) w)
          = case b of
              BLeft    -> Bin (Bin t (p, Balanced) u)
                              (q, Balanced)
                              (Bin v (r, BRight) w)
              BRight   -> Bin (Bin t (p, BLeft) u)
                              (q, Balanced)
                              (Bin v (r, Balanced) w)
              Balanced -> Bin (Bin t (p, Balanced) u)
                              (q, Balanced)
                              (Bin v (r, Balanced) w)                
        rotLeftRight _ = error "rotLeftRight error"
        rotRightLeft :: BTree (a, Balance) -> BTree (a, Balance)
        rotRightLeft (Bin t (r, _) (Bin (Bin u (q, b) v) (p, _) w))
          = case b of
              BLeft    -> Bin (Bin t (r, Balanced) u)
                              (q, Balanced)
                              (Bin v (p, BRight) w)
              BRight   -> Bin (Bin t (r, BLeft) u)
                              (q, Balanced)
                              (Bin v (p, Balanced) w)
              Balanced -> Bin (Bin t (r, Balanced) u)
                              (q, Balanced)
                              (Bin v (p, Balanced) w)                
        rotRightLeft _ = error "rotRightLeft error"

-- addListToAvl : add a list to an AVL tree
addListToAvl :: (a -> a -> a) -> (a -> a -> Ordering)
                  -> AvlTree a -> [a] -> AvlTree a
addListToAvl option order
  = foldl (addToAvl option order)

-- makeAvl : make an AVL tree
makeAvl :: (a -> a -> a) -> (a -> a -> Ordering) -> [a] -> AvlTree a
makeAvl option order = addListToAvl option order Empty


-- Archive : data structure for BFS
data Arch a
  = Arch { archElements :: AvlTree a
         , archOrder    :: a -> a -> Ordering
         } 

-- addToArchive : add an element to archive (addToSet)
addToArchive :: Arch a -> a -> Arch a
addToArchive arch x
  = arch { archElements =
             addToAvl (\x -> \y -> x) (archOrder arch) (archElements arch) x }

-- addListToArchive : add a list to archive (addListToSet)
addListToArchive :: Arch a -> [a] -> Arch a
addListToArchive arch l = foldl addToArchive arch l

-- makeArchive : make an archive (w.r.t. some ordering) (makeSet)
makeArchive :: (a -> a -> Ordering) -> [a] -> Arch a
makeArchive comp l = Arch (makeAvl (\x -> \y -> x) comp l) comp

-- archiveMember : test whether an element belongs to an archive (setMember)
archiveMember :: a -> Arch a -> Bool
archiveMember x arch = belongsToAvl (archOrder arch) x (archElements arch)

-- archiveMap : archive management
archiveMap :: (a -> b) -> (c -> [a]) -> (Arch b, [c]) -> (Arch b, [a])
archiveMap archPart f (arch, l)
  = archMap arch [] (trace (show (length l) ++ "\t") l) -- l
      where
        archMap arch ll [] = (arch, ll)
        archMap arch ll (h : t)
          = let ll' =
                  select (\c -> not (archiveMember (archPart c) arch)) (f h)
             in archMap
                (addListToArchive arch (map archPart ll'))
                (ll' ++ ll)
                t


-- LIST : general list
class LIST a where
  -- update : replace an element by another in the list
  update :: a -> a -> [a] -> [a]

  -- insert : insert an element into the list (w.r.t. some comparison method)
  insert :: (a -> a -> Ordering) -> a -> [a] -> [a]

  -- sort : sort the list w.r.t. some comparison method
  sort :: (a -> a -> Ordering) -> [a] -> [a]

instance LIST Int where
  update _ _ [] = []
  update x y (h : t) | x == h = y : t
                     | x /= h = h : (update x y t)

  insert _ x [] = [x]
  insert comp x (h : t)
    = case comp x h of
        LT -> x : (h : t)
        EQ -> x : (h : t)
        GT -> h : (insert comp x t)

  sort comp l = foldr (insert comp) [] l


-- For executing the program
-- solveHRD start okStatus

-- For debugging
-- solveHRDTrace start okStatus