module ListF(listF,untaggedListF) where
import CompF
import CompSP(prepostMapSP)
import CompSP(preMapSP)
import CompOps((>^=<),(>=^^<))
import Direction
import Fudget
--import ListMap(lookupWithDefault)
--import Message(Message(..))
--import NullF
--import Path(Path(..))
import Spops
import TreeF
import Utils(number,pair)
import HbcUtils(apSnd,lookupWithDefault)
import LayoutHints

untaggedListF :: [F a b] -> F a b
untaggedListF :: [F a b] -> F a b
untaggedListF [F a b]
fs = (Int, b) -> b
forall a b. (a, b) -> b
snd ((Int, b) -> b) -> F (Int, a) (Int, b) -> F (Int, a) b
forall a b e. (a -> b) -> F e a -> F e b
>^=< [(Int, F a b)] -> F (Int, a) (Int, b)
forall a b c. Eq a => [(a, F b c)] -> F (a, b) (a, c)
listF [(Int, F a b)]
tfs F (Int, a) b -> SP a (Int, a) -> F a b
forall c d e. F c d -> SP e c -> F e d
>=^^< (a -> [(Int, a)]) -> SP a (Int, a)
forall t b. (t -> [b]) -> SP t b
concatMapSP a -> [(Int, a)]
forall b. b -> [(Int, b)]
broadcast
  where
    tfs :: [(Int, F a b)]
tfs = Int -> [F a b] -> [(Int, F a b)]
forall a. Int -> [a] -> [(Int, a)]
number Int
0 [F a b]
fs
    ns :: [Int]
ns = ((Int, F a b) -> Int) -> [(Int, F a b)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int, F a b) -> Int
forall a b. (a, b) -> a
fst [(Int, F a b)]
tfs
    broadcast :: b -> [(Int, b)]
broadcast b
x = (Int -> (Int, b)) -> [Int] -> [(Int, b)]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> b -> (Int, b)
forall a b. a -> b -> (a, b)
`pair` b
x) [Int]
ns

listF :: {-Prelude.-}Eq a => [(a, F b c)] -> F (a, b) (a, c)
listF :: [(a, F b c)] -> F (a, b) (a, c)
listF = LayoutHint -> F (a, b) (a, c) -> F (a, b) (a, c)
forall a b. LayoutHint -> F a b -> F a b
layoutHintF LayoutHint
listHint (F (a, b) (a, c) -> F (a, b) (a, c))
-> ([(a, F b c)] -> F (a, b) (a, c))
-> [(a, F b c)]
-> F (a, b) (a, c)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FSP (a, b) (a, c) -> F (a, b) (a, c)
forall hi ho. FSP hi ho -> F hi ho
F{-ff-} (FSP (a, b) (a, c) -> F (a, b) (a, c))
-> ([(a, F b c)] -> FSP (a, b) (a, c))
-> [(a, F b c)]
-> F (a, b) (a, c)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(a, F b c)] -> FSP (a, b) (a, c)
forall a b c. Eq a => [(a, F b c)] -> FSP (a, b) (a, c)
listF'

listF' :: Eq a => [(a, F b c)] -> FSP (a, b) (a, c)
listF' :: [(a, F b c)] -> FSP (a, b) (a, c)
listF' [(a
tag, F FSP b c
w)] =
    let prepinp :: Message a (a, b) -> Message a b
prepinp (High (a
t, b
a)) =
            if a
t a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
tag then b -> Message a b
forall a b. b -> Message a b
High b
a else LayoutHint -> Message a b
forall a. HasCallStack => LayoutHint -> a
error LayoutHint
"Unknown tag in listF"
        prepinp (Low a
tev) = a -> Message a b
forall a b. a -> Message a b
Low a
tev
        prepout :: Message a b -> Message a (a, b)
prepout (High b
b) = (a, b) -> Message a (a, b)
forall a b. b -> Message a b
High (a
tag, b
b)
        prepout (Low a
cmd) = a -> Message a (a, b)
forall a b. a -> Message a b
Low a
cmd
    in  (Message TEvent (a, b) -> Message TEvent b)
-> (Message TCommand c -> Message TCommand (a, c))
-> FSP b c
-> FSP (a, b) (a, c)
forall t1 a t2 b. (t1 -> a) -> (t2 -> b) -> SP a t2 -> SP t1 b
prepostMapSP Message TEvent (a, b) -> Message TEvent b
forall a b. Message a (a, b) -> Message a b
prepinp Message TCommand c -> Message TCommand (a, c)
forall a b. Message a b -> Message a (a, b)
prepout FSP b c
w
listF' [(a
ltag, F b c
lw), (a
rtag, F b c
rw)] =
    let prepinp :: Message a (a, b) -> Message a (Either b b)
prepinp (High (a
tag, b
a)) =
            if a
tag a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
ltag then
                Either b b -> Message a (Either b b)
forall a b. b -> Message a b
High (b -> Either b b
forall a b. a -> Either a b
Left b
a)
            else
                if a
tag a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
rtag then
                    Either b b -> Message a (Either b b)
forall a b. b -> Message a b
High (b -> Either b b
forall a b. b -> Either a b
Right b
a)
                else
                    LayoutHint -> Message a (Either b b)
forall a. HasCallStack => LayoutHint -> a
error LayoutHint
"Unknown tag in listF"
        prepinp (Low a
tev) = a -> Message a (Either b b)
forall a b. a -> Message a b
Low a
tev
        prepout :: Message a (Either b b) -> Message a (a, b)
prepout (High (Left b
b)) = (a, b) -> Message a (a, b)
forall a b. b -> Message a b
High (a
ltag, b
b)
        prepout (High (Right b
b)) = (a, b) -> Message a (a, b)
forall a b. b -> Message a b
High (a
rtag, b
b)
        prepout (Low a
cmd) = a -> Message a (a, b)
forall a b. a -> Message a b
Low a
cmd
        F FSP (Either b b) (Either c c)
lwrw = F b c -> F b c -> F (Either b b) (Either c c)
forall a b c d. F a b -> F c d -> F (Either a c) (Either b d)
compF F b c
lw F b c
rw
    in  (Message TEvent (a, b) -> Message TEvent (Either b b))
-> (Message TCommand (Either c c) -> Message TCommand (a, c))
-> FSP (Either b b) (Either c c)
-> FSP (a, b) (a, c)
forall t1 a t2 b. (t1 -> a) -> (t2 -> b) -> SP a t2 -> SP t1 b
prepostMapSP Message TEvent (a, b) -> Message TEvent (Either b b)
forall a b. Message a (a, b) -> Message a (Either b b)
prepinp Message TCommand (Either c c) -> Message TCommand (a, c)
forall a b. Message a (Either b b) -> Message a (a, b)
prepout FSP (Either b b) (Either c c)
lwrw
listF' [] = FSP (a, b) (a, c)
forall a b. SP a b
nullSP
listF' [(a, F b c)]
wtab =
    let tree :: Tree (a, F b c)
tree = [(a, F b c)] -> Tree (a, F b c)
forall a. [a] -> Tree a
balancedTree [(a, F b c)]
wtab
        paths :: [(a, [Direction])]
paths = Tree (a, F b c) -> [(a, [Direction])]
forall a b. Tree (a, b) -> [(a, [Direction])]
pathtab Tree (a, F b c)
tree
        prepinp :: Message a (a, b) -> Message a ([Direction], b)
prepinp (High (a
tag, b
a)) =
            let path' :: [Direction]
path' = [(a, [Direction])] -> [Direction] -> a -> [Direction]
forall a b. Eq a => [(a, b)] -> b -> a -> b
lookupWithDefault [(a, [Direction])]
paths (LayoutHint -> [Direction]
forall a. HasCallStack => LayoutHint -> a
error LayoutHint
"Unknown tag in listF") a
tag
            in  ([Direction], b) -> Message a ([Direction], b)
forall a b. b -> Message a b
High ([Direction]
path', b
a)
        prepinp (Low a
tev) = a -> Message a ([Direction], b)
forall a b. a -> Message a b
Low a
tev
    in  SP (FEvent ([Direction], b)) (Message TCommand (a, c))
-> (Message TEvent (a, b) -> FEvent ([Direction], b))
-> FSP (a, b) (a, c)
forall a b t. SP a b -> (t -> a) -> SP t b
preMapSP (Tree (a, F b c)
-> SP (FEvent ([Direction], b)) (Message TCommand (a, c))
forall a b c. Tree (a, F b c) -> FSP ([Direction], b) (a, c)
treeF' Tree (a, F b c)
tree) Message TEvent (a, b) -> FEvent ([Direction], b)
forall a b. Message a (a, b) -> Message a ([Direction], b)
prepinp

pathtab :: Tree (a, b) -> [(a, [Direction])]
pathtab (Leaf (a
t, b
_)) = [(a
t, [])]
pathtab (Branch Tree (a, b)
l Tree (a, b)
r) =
    ((a, [Direction]) -> (a, [Direction]))
-> [(a, [Direction])] -> [(a, [Direction])]
forall a b. (a -> b) -> [a] -> [b]
map (([Direction] -> [Direction])
-> (a, [Direction]) -> (a, [Direction])
forall t b a. (t -> b) -> (a, t) -> (a, b)
apSnd (Direction
L Direction -> [Direction] -> [Direction]
forall a. a -> [a] -> [a]
:)) (Tree (a, b) -> [(a, [Direction])]
pathtab Tree (a, b)
l) [(a, [Direction])] -> [(a, [Direction])] -> [(a, [Direction])]
forall a. [a] -> [a] -> [a]
++ ((a, [Direction]) -> (a, [Direction]))
-> [(a, [Direction])] -> [(a, [Direction])]
forall a b. (a -> b) -> [a] -> [b]
map (([Direction] -> [Direction])
-> (a, [Direction]) -> (a, [Direction])
forall t b a. (t -> b) -> (a, t) -> (a, b)
apSnd (Direction
R Direction -> [Direction] -> [Direction]
forall a. a -> [a] -> [a]
:)) (Tree (a, b) -> [(a, [Direction])]
pathtab Tree (a, b)
r)

balancedTree :: [a] -> Tree a
balancedTree [a]
xs =
    case [a]
xs of
      [a
x] -> a -> Tree a
forall a. a -> Tree a
Leaf a
x
      [a]
_ -> let ([a]
l, [a]
r) = [a] -> ([a], [a])
forall a. [a] -> ([a], [a])
split2 [a]
xs
           in  Tree a -> Tree a -> Tree a
forall a. Tree a -> Tree a -> Tree a
Branch ([a] -> Tree a
balancedTree [a]
l) ([a] -> Tree a
balancedTree [a]
r)

split2 :: [a] -> ([a], [a])
split2 [a]
l =
    let sp :: Int
sp = [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
l Int -> Int -> Int
forall a. Integral a => a -> a -> a
`quot` Int
2
    in  (Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
take Int
sp [a]
l, Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
drop Int
sp [a]
l)