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(turn,Direction(..))
import Spops
import TreeF
import Utils(number,pair)
import HbcUtils(apSnd,lookupWithDefault)
import LayoutHints

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

listF :: {-Prelude.-}Eq a => [(a, F b c)] -> F (a, b) (a, c)
listF :: forall a b c. Eq a => [(a, F b c)] -> F (a, b) (a, c)
listF = forall a b. LayoutHint -> F a b -> F a b
layoutHintF LayoutHint
listHint forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall hi ho. FSP hi ho -> F hi ho
F{-ff-} forall b c a. (b -> c) -> (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' :: forall a b c. Eq a => [(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 forall a. Eq a => a -> a -> Bool
== a
tag then forall a b. b -> Message a b
High b
a else forall a. HasCallStack => LayoutHint -> a
error LayoutHint
"Unknown tag in listF"
        prepinp (Low a
tev) = forall a b. a -> Message a b
Low a
tev
        prepout :: Message a b -> Message a (a, b)
prepout (High b
b) = forall a b. b -> Message a b
High (a
tag, b
b)
        prepout (Low a
cmd) = forall a b. a -> Message a b
Low a
cmd
    in  forall {t1} {a} {t2} {b}.
(t1 -> a) -> (t2 -> b) -> SP a t2 -> SP t1 b
prepostMapSP forall {a} {b}. Message a (a, b) -> Message a b
prepinp 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 forall a. Eq a => a -> a -> Bool
== a
ltag then
                forall a b. b -> Message a b
High (forall a b. a -> Either a b
Left b
a)
            else
                if a
tag forall a. Eq a => a -> a -> Bool
== a
rtag then
                    forall a b. b -> Message a b
High (forall a b. b -> Either a b
Right b
a)
                else
                    forall a. HasCallStack => LayoutHint -> a
error LayoutHint
"Unknown tag in listF"
        prepinp (Low a
tev) = 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)) = forall a b. b -> Message a b
High (a
ltag, b
b)
        prepout (High (Right b
b)) = forall a b. b -> Message a b
High (a
rtag, b
b)
        prepout (Low a
cmd) = forall a b. a -> Message a b
Low a
cmd
        F FSP (Either b b) (Either c c)
lwrw = 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  forall {t1} {a} {t2} {b}.
(t1 -> a) -> (t2 -> b) -> SP a t2 -> SP t1 b
prepostMapSP forall {a} {b}. Message a (a, b) -> Message a (Either b b)
prepinp forall {a} {b}. Message a (Either b b) -> Message a (a, b)
prepout FSP (Either b b) (Either c c)
lwrw
listF' [] = forall a b. SP a b
nullSP
listF' [(a, F b c)]
wtab =
    let tree :: Tree (a, F b c)
tree = forall {a}. [a] -> Tree a
balancedTree [(a, F b c)]
wtab
        paths :: [(a, Path)]
paths = forall {a} {b}. Tree (a, b) -> [(a, Path)]
pathtab Tree (a, F b c)
tree
        prepinp :: Message a (a, b) -> Message a (Path, b)
prepinp (High (a
tag, b
a)) =
            let path' :: Path
path' = forall a b. Eq a => [(a, b)] -> b -> a -> b
lookupWithDefault [(a, Path)]
paths (forall a. HasCallStack => LayoutHint -> a
error LayoutHint
"Unknown tag in listF") a
tag
            in  forall a b. b -> Message a b
High (Path
path', b
a)
        prepinp (Low a
tev) = forall a b. a -> Message a b
Low a
tev
    in  forall {a} {b} {t}. SP a b -> (t -> a) -> SP t b
preMapSP (forall a b c. Tree (a, F b c) -> FSP (Path, b) (a, c)
treeF' Tree (a, F b c)
tree) forall {a} {b}. Message a (a, b) -> Message a (Path, b)
prepinp

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

balancedTree :: [a] -> Tree a
balancedTree [a]
xs =
    case [a]
xs of
      [a
x] -> forall a. a -> Tree a
Leaf a
x
      [a]
_ -> let ([a]
l, [a]
r) = forall {a}. [a] -> ([a], [a])
split2 [a]
xs
           in  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 = forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
l forall a. Integral a => a -> a -> a
`quot` Int
2
    in  (forall a. Int -> [a] -> [a]
take Int
sp [a]
l, forall a. Int -> [a] -> [a]
drop Int
sp [a]
l)