module CodeWorld.Sharing.HashCons (
  Node(..),
  NodeId,
  BiMap,
  getNodes,
  hashconsShare,
) where


import Control.Monad.State              (State, get, put, runState)
import Data.List                        (elemIndex)
import Data.Text                        (Text)

import CodeWorld.Tasks.API              (Drawable(..))
import CodeWorld.Tasks.Color            (Color)
import CodeWorld.Tasks.Types            (Font, TextStyle)
import CodeWorld.Tasks.VectorSpace      (Point)



type NodeId = Int

data Node
  = RectangleNode Double Double
  | ThickRectangleNode Double Double Double
  | SolidRectangleNode Double Double
  | CircleNode Double
  | ThickCircleNode Double Double
  | SolidCircleNode Double
  | PolygonNode [Point]
  | SolidPolygonNode [Point]
  | ThickPolygonNode Double [Point]
  | ClosedCurveNode [Point]
  | SolidClosedCurveNode [Point]
  | ThickClosedCurveNode Double [Point]
  | PolylineNode [Point]
  | ThickPolylineNode Double [Point]
  | CurveNode [Point]
  | ThickCurveNode Double [Point]
  | SectorNode Double Double Double
  | ArcNode Double Double Double
  | ThickArcNode Double Double Double Double
  | LetteringNode Text
  | StyledLetteringNode TextStyle Font Text
  | ColorNode Color NodeId
  | TranslateNode Double Double NodeId
  | ScaleNode Double Double NodeId
  | DilateNode Double NodeId
  | RotateNode Double NodeId
  | ReflectNode Double NodeId
  | ClipNode Double Double NodeId
  | PicturesNode [NodeId]
  | AndNode NodeId NodeId
  | CoordinatePlaneNode
  | LogoNode
  | BlankNode
  deriving (Node -> Node -> Bool
(Node -> Node -> Bool) -> (Node -> Node -> Bool) -> Eq Node
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Node -> Node -> Bool
== :: Node -> Node -> Bool
$c/= :: Node -> Node -> Bool
/= :: Node -> Node -> Bool
Eq,Eq Node
Eq Node =>
(Node -> Node -> Ordering)
-> (Node -> Node -> Bool)
-> (Node -> Node -> Bool)
-> (Node -> Node -> Bool)
-> (Node -> Node -> Bool)
-> (Node -> Node -> Node)
-> (Node -> Node -> Node)
-> Ord Node
Node -> Node -> Bool
Node -> Node -> Ordering
Node -> Node -> Node
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Node -> Node -> Ordering
compare :: Node -> Node -> Ordering
$c< :: Node -> Node -> Bool
< :: Node -> Node -> Bool
$c<= :: Node -> Node -> Bool
<= :: Node -> Node -> Bool
$c> :: Node -> Node -> Bool
> :: Node -> Node -> Bool
$c>= :: Node -> Node -> Bool
>= :: Node -> Node -> Bool
$cmax :: Node -> Node -> Node
max :: Node -> Node -> Node
$cmin :: Node -> Node -> Node
min :: Node -> Node -> Node
Ord,NodeId -> Node -> ShowS
[Node] -> ShowS
Node -> String
(NodeId -> Node -> ShowS)
-> (Node -> String) -> ([Node] -> ShowS) -> Show Node
forall a.
(NodeId -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: NodeId -> Node -> ShowS
showsPrec :: NodeId -> Node -> ShowS
$cshow :: Node -> String
show :: Node -> String
$cshowList :: [Node] -> ShowS
showList :: [Node] -> ShowS
Show)


newtype DAG = DAG (BiMap Node) deriving NodeId -> DAG -> ShowS
[DAG] -> ShowS
DAG -> String
(NodeId -> DAG -> ShowS)
-> (DAG -> String) -> ([DAG] -> ShowS) -> Show DAG
forall a.
(NodeId -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: NodeId -> DAG -> ShowS
showsPrec :: NodeId -> DAG -> ShowS
$cshow :: DAG -> String
show :: DAG -> String
$cshowList :: [DAG] -> ShowS
showList :: [DAG] -> ShowS
Show
newtype Runner = Runner { Runner -> State DAG NodeId
unRunner :: State DAG NodeId}
type BiMap a = [(NodeId,a)]


instance Drawable Runner where
  coordinatePlane :: Runner
coordinatePlane      = Node -> Runner
toRunnerSimple Node
CoordinatePlaneNode
  codeWorldLogo :: Runner
codeWorldLogo        = Node -> Runner
toRunnerSimple Node
LogoNode
  blank :: Runner
blank                = Node -> Runner
toRunnerSimple Node
BlankNode
  rectangle :: Double -> Double -> Runner
rectangle Double
x          = Node -> Runner
toRunnerSimple (Node -> Runner) -> (Double -> Node) -> Double -> Runner
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Double -> Node
RectangleNode Double
x
  thickRectangle :: Double -> Double -> Double -> Runner
thickRectangle Double
t Double
x   = Node -> Runner
toRunnerSimple (Node -> Runner) -> (Double -> Node) -> Double -> Runner
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Double -> Double -> Node
ThickRectangleNode Double
t Double
x
  solidRectangle :: Double -> Double -> Runner
solidRectangle Double
x     = Node -> Runner
toRunnerSimple (Node -> Runner) -> (Double -> Node) -> Double -> Runner
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Double -> Node
SolidRectangleNode Double
x
  circle :: Double -> Runner
circle               = Node -> Runner
toRunnerSimple (Node -> Runner) -> (Double -> Node) -> Double -> Runner
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Node
CircleNode
  thickCircle :: Double -> Double -> Runner
thickCircle Double
t        = Node -> Runner
toRunnerSimple (Node -> Runner) -> (Double -> Node) -> Double -> Runner
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Double -> Node
ThickCircleNode Double
t
  solidCircle :: Double -> Runner
solidCircle          = Node -> Runner
toRunnerSimple (Node -> Runner) -> (Double -> Node) -> Double -> Runner
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Node
SolidCircleNode
  arc :: Double -> Double -> Double -> Runner
arc Double
a1 Double
a2            = Node -> Runner
toRunnerSimple (Node -> Runner) -> (Double -> Node) -> Double -> Runner
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Double -> Double -> Node
ArcNode Double
a1 Double
a2
  sector :: Double -> Double -> Double -> Runner
sector Double
a1 Double
a2         = Node -> Runner
toRunnerSimple (Node -> Runner) -> (Double -> Node) -> Double -> Runner
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Double -> Double -> Node
SectorNode Double
a1 Double
a2
  thickArc :: Double -> Double -> Double -> Double -> Runner
thickArc Double
t Double
a1 Double
a2     = Node -> Runner
toRunnerSimple (Node -> Runner) -> (Double -> Node) -> Double -> Runner
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Double -> Double -> Double -> Node
ThickArcNode Double
t Double
a1 Double
a2
  curve :: [Point] -> Runner
curve                = Node -> Runner
toRunnerSimple (Node -> Runner) -> ([Point] -> Node) -> [Point] -> Runner
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Point] -> Node
CurveNode
  thickCurve :: Double -> [Point] -> Runner
thickCurve Double
t         = Node -> Runner
toRunnerSimple (Node -> Runner) -> ([Point] -> Node) -> [Point] -> Runner
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> [Point] -> Node
ThickCurveNode Double
t
  closedCurve :: [Point] -> Runner
closedCurve          = Node -> Runner
toRunnerSimple (Node -> Runner) -> ([Point] -> Node) -> [Point] -> Runner
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Point] -> Node
ClosedCurveNode
  thickClosedCurve :: Double -> [Point] -> Runner
thickClosedCurve Double
t   = Node -> Runner
toRunnerSimple (Node -> Runner) -> ([Point] -> Node) -> [Point] -> Runner
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> [Point] -> Node
ThickClosedCurveNode Double
t
  solidClosedCurve :: [Point] -> Runner
solidClosedCurve     = Node -> Runner
toRunnerSimple (Node -> Runner) -> ([Point] -> Node) -> [Point] -> Runner
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Point] -> Node
SolidClosedCurveNode
  polyline :: [Point] -> Runner
polyline             = Node -> Runner
toRunnerSimple (Node -> Runner) -> ([Point] -> Node) -> [Point] -> Runner
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Point] -> Node
PolylineNode
  thickPolyline :: Double -> [Point] -> Runner
thickPolyline Double
t      = Node -> Runner
toRunnerSimple (Node -> Runner) -> ([Point] -> Node) -> [Point] -> Runner
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> [Point] -> Node
ThickPolylineNode Double
t
  polygon :: [Point] -> Runner
polygon              = Node -> Runner
toRunnerSimple (Node -> Runner) -> ([Point] -> Node) -> [Point] -> Runner
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Point] -> Node
PolygonNode
  solidPolygon :: [Point] -> Runner
solidPolygon         = Node -> Runner
toRunnerSimple (Node -> Runner) -> ([Point] -> Node) -> [Point] -> Runner
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Point] -> Node
SolidPolygonNode
  thickPolygon :: Double -> [Point] -> Runner
thickPolygon Double
t       = Node -> Runner
toRunnerSimple (Node -> Runner) -> ([Point] -> Node) -> [Point] -> Runner
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> [Point] -> Node
ThickPolygonNode Double
t
  lettering :: Text -> Runner
lettering            = Node -> Runner
toRunnerSimple (Node -> Runner) -> (Text -> Node) -> Text -> Runner
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Node
LetteringNode
  styledLettering :: TextStyle -> Font -> Text -> Runner
styledLettering TextStyle
ts Font
f = Node -> Runner
toRunnerSimple (Node -> Runner) -> (Text -> Node) -> Text -> Runner
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TextStyle -> Font -> Text -> Node
StyledLetteringNode TextStyle
ts Font
f

  colored :: Color -> Runner -> Runner
colored Color
c      = (NodeId -> Node) -> Runner -> Runner
toRunnerSingle ((NodeId -> Node) -> Runner -> Runner)
-> (NodeId -> Node) -> Runner -> Runner
forall a b. (a -> b) -> a -> b
$ Color -> NodeId -> Node
ColorNode Color
c
  translated :: Double -> Double -> Runner -> Runner
translated Double
x Double
y = (NodeId -> Node) -> Runner -> Runner
toRunnerSingle ((NodeId -> Node) -> Runner -> Runner)
-> (NodeId -> Node) -> Runner -> Runner
forall a b. (a -> b) -> a -> b
$ Double -> Double -> NodeId -> Node
TranslateNode Double
x Double
y
  scaled :: Double -> Double -> Runner -> Runner
scaled Double
x Double
y     = (NodeId -> Node) -> Runner -> Runner
toRunnerSingle ((NodeId -> Node) -> Runner -> Runner)
-> (NodeId -> Node) -> Runner -> Runner
forall a b. (a -> b) -> a -> b
$ Double -> Double -> NodeId -> Node
ScaleNode Double
x Double
y
  dilated :: Double -> Runner -> Runner
dilated Double
d      = (NodeId -> Node) -> Runner -> Runner
toRunnerSingle ((NodeId -> Node) -> Runner -> Runner)
-> (NodeId -> Node) -> Runner -> Runner
forall a b. (a -> b) -> a -> b
$ Double -> NodeId -> Node
DilateNode Double
d
  rotated :: Double -> Runner -> Runner
rotated Double
a      = (NodeId -> Node) -> Runner -> Runner
toRunnerSingle ((NodeId -> Node) -> Runner -> Runner)
-> (NodeId -> Node) -> Runner -> Runner
forall a b. (a -> b) -> a -> b
$ Double -> NodeId -> Node
RotateNode Double
a
  reflected :: Double -> Runner -> Runner
reflected Double
a    = (NodeId -> Node) -> Runner -> Runner
toRunnerSingle ((NodeId -> Node) -> Runner -> Runner)
-> (NodeId -> Node) -> Runner -> Runner
forall a b. (a -> b) -> a -> b
$ Double -> NodeId -> Node
ReflectNode Double
a
  clipped :: Double -> Double -> Runner -> Runner
clipped Double
x Double
y    = (NodeId -> Node) -> Runner -> Runner
toRunnerSingle ((NodeId -> Node) -> Runner -> Runner)
-> (NodeId -> Node) -> Runner -> Runner
forall a b. (a -> b) -> a -> b
$ Double -> Double -> NodeId -> Node
ClipNode Double
x Double
y

  pictures :: [Runner] -> Runner
pictures [Runner]
ps = State DAG NodeId -> Runner
Runner (State DAG NodeId -> Runner) -> State DAG NodeId -> Runner
forall a b. (a -> b) -> a -> b
$ do
    [NodeId]
hs <- (Runner -> State DAG NodeId)
-> [Runner] -> StateT DAG Identity [NodeId]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Runner -> State DAG NodeId
unRunner [Runner]
ps
    Node -> State DAG NodeId
hashcons (Node -> State DAG NodeId) -> Node -> State DAG NodeId
forall a b. (a -> b) -> a -> b
$ [NodeId] -> Node
PicturesNode [NodeId]
hs

  Runner
p & :: Runner -> Runner -> Runner
& Runner
q = State DAG NodeId -> Runner
Runner (State DAG NodeId -> Runner) -> State DAG NodeId -> Runner
forall a b. (a -> b) -> a -> b
$ do
    NodeId
h1 <- Runner -> State DAG NodeId
unRunner Runner
p
    NodeId
h2 <- Runner -> State DAG NodeId
unRunner Runner
q
    Node -> State DAG NodeId
hashcons (Node -> State DAG NodeId) -> Node -> State DAG NodeId
forall a b. (a -> b) -> a -> b
$ NodeId -> NodeId -> Node
AndNode NodeId
h1 NodeId
h2


toRunnerSimple :: Node -> Runner
toRunnerSimple :: Node -> Runner
toRunnerSimple = State DAG NodeId -> Runner
Runner (State DAG NodeId -> Runner)
-> (Node -> State DAG NodeId) -> Node -> Runner
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Node -> State DAG NodeId
hashcons


toRunnerSingle :: (NodeId -> Node) -> Runner -> Runner
toRunnerSingle :: (NodeId -> Node) -> Runner -> Runner
toRunnerSingle NodeId -> Node
f Runner
x = State DAG NodeId -> Runner
Runner (State DAG NodeId -> Runner) -> State DAG NodeId -> Runner
forall a b. (a -> b) -> a -> b
$ do
    NodeId
hs <- Runner -> State DAG NodeId
unRunner Runner
x
    Node -> State DAG NodeId
hashcons (Node -> State DAG NodeId) -> Node -> State DAG NodeId
forall a b. (a -> b) -> a -> b
$ NodeId -> Node
f NodeId
hs


lookupKey :: Ord a => a -> BiMap a -> Maybe NodeId
lookupKey :: forall a. Ord a => a -> BiMap a -> Maybe NodeId
lookupKey a
a BiMap a
xs = a -> [a] -> Maybe NodeId
forall a. Eq a => a -> [a] -> Maybe NodeId
elemIndex a
a ([a] -> Maybe NodeId) -> [a] -> Maybe NodeId
forall a b. (a -> b) -> a -> b
$ ((NodeId, a) -> a) -> BiMap a -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (NodeId, a) -> a
forall a b. (a, b) -> b
snd BiMap a
xs


lookupVal :: NodeId -> BiMap a -> a
lookupVal :: forall a. NodeId -> BiMap a -> a
lookupVal NodeId
i BiMap a
xs = (NodeId, a) -> a
forall a b. (a, b) -> b
snd ((NodeId, a) -> a) -> (NodeId, a) -> a
forall a b. (a -> b) -> a -> b
$ BiMap a
xs BiMap a -> NodeId -> (NodeId, a)
forall a. HasCallStack => [a] -> NodeId -> a
!! NodeId
i


insert :: a -> BiMap a -> (Int, BiMap a)
insert :: forall a. a -> BiMap a -> (NodeId, BiMap a)
insert a
a BiMap a
xs = let i :: NodeId
i = BiMap a -> NodeId
forall a. [a] -> NodeId
forall (t :: * -> *) a. Foldable t => t a -> NodeId
length BiMap a
xs in (NodeId
i,BiMap a
xsBiMap a -> BiMap a -> BiMap a
forall a. [a] -> [a] -> [a]
++[(NodeId
i,a
a)])


empty :: [a]
empty :: forall a. [a]
empty = []


run :: Runner -> (NodeId, DAG)
run :: Runner -> (NodeId, DAG)
run (Runner State DAG NodeId
m) = State DAG NodeId -> DAG -> (NodeId, DAG)
forall s a. State s a -> s -> (a, s)
runState State DAG NodeId
m (BiMap Node -> DAG
DAG BiMap Node
forall a. [a]
empty)


hashcons :: Node -> State DAG NodeId
hashcons :: Node -> State DAG NodeId
hashcons Node
e = do
  DAG BiMap Node
m <- StateT DAG Identity DAG
forall s (m :: * -> *). MonadState s m => m s
get
  case Node -> BiMap Node -> Maybe NodeId
forall a. Ord a => a -> BiMap a -> Maybe NodeId
lookupKey Node
e BiMap Node
m of
    Maybe NodeId
Nothing ->
      let (NodeId
k, BiMap Node
m') = Node -> BiMap Node -> (NodeId, BiMap Node)
forall a. a -> BiMap a -> (NodeId, BiMap a)
insert Node
e BiMap Node
m
      in DAG -> StateT DAG Identity ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (BiMap Node -> DAG
DAG BiMap Node
m') StateT DAG Identity () -> State DAG NodeId -> State DAG NodeId
forall a b.
StateT DAG Identity a
-> StateT DAG Identity b -> StateT DAG Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> NodeId -> State DAG NodeId
forall a. a -> StateT DAG Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return NodeId
k
    Just NodeId
k -> NodeId -> State DAG NodeId
forall a. a -> StateT DAG Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return NodeId
k


hashconsShare :: Runner -> (BiMap Node,BiMap Node)
hashconsShare :: Runner -> (BiMap Node, BiMap Node)
hashconsShare Runner
r = ((NodeId -> (NodeId, Node)) -> [NodeId] -> BiMap Node
forall a b. (a -> b) -> [a] -> [b]
map (\NodeId
i -> (NodeId
i, NodeId -> BiMap Node -> Node
forall a. NodeId -> BiMap a -> a
lookupVal NodeId
i BiMap Node
bimap)) [NodeId]
shared, BiMap Node
bimap)
  where
    (NodeId
_, DAG BiMap Node
bimap) = Runner -> (NodeId, DAG)
run Runner
r
    indices :: [NodeId]
indices = ((NodeId, Node) -> [NodeId]) -> BiMap Node -> [NodeId]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Node -> [NodeId]
getNodes (Node -> [NodeId])
-> ((NodeId, Node) -> Node) -> (NodeId, Node) -> [NodeId]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NodeId, Node) -> Node
forall a b. (a, b) -> b
snd) BiMap Node
bimap
    keys :: [NodeId]
keys = ((NodeId, Node) -> NodeId) -> BiMap Node -> [NodeId]
forall a b. (a -> b) -> [a] -> [b]
map (NodeId, Node) -> NodeId
forall a b. (a, b) -> a
fst BiMap Node
bimap
    count :: a -> [a] -> NodeId
count a
x = [a] -> NodeId
forall a. [a] -> NodeId
forall (t :: * -> *) a. Foldable t => t a -> NodeId
length ([a] -> NodeId) -> ([a] -> [a]) -> [a] -> NodeId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Bool) -> [a] -> [a]
forall a. (a -> Bool) -> [a] -> [a]
filter (a -> a -> Bool
forall a. Eq a => a -> a -> Bool
==a
x)
    shared :: [NodeId]
shared = (NodeId -> Bool) -> [NodeId] -> [NodeId]
forall a. (a -> Bool) -> [a] -> [a]
filter ((NodeId -> NodeId -> Bool
forall a. Ord a => a -> a -> Bool
> NodeId
1) (NodeId -> Bool) -> (NodeId -> NodeId) -> NodeId -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NodeId -> [NodeId] -> NodeId) -> [NodeId] -> NodeId -> NodeId
forall a b c. (a -> b -> c) -> b -> a -> c
flip NodeId -> [NodeId] -> NodeId
forall {a}. Eq a => a -> [a] -> NodeId
count [NodeId]
indices) [NodeId]
keys


getNodes :: Node -> [NodeId]
getNodes :: Node -> [NodeId]
getNodes Node
n = case Node
n of
  ColorNode Color
_ NodeId
i       -> [NodeId
i]
  TranslateNode Double
_ Double
_ NodeId
i -> [NodeId
i]
  ScaleNode Double
_ Double
_ NodeId
i     -> [NodeId
i]
  DilateNode Double
_ NodeId
i      -> [NodeId
i]
  RotateNode Double
_ NodeId
i      -> [NodeId
i]
  ReflectNode Double
_ NodeId
i     -> [NodeId
i]
  ClipNode Double
_ Double
_ NodeId
i      -> [NodeId
i]
  PicturesNode [NodeId]
is     -> [NodeId]
is
  AndNode NodeId
i1 NodeId
i2       -> [NodeId
i1,NodeId
i2]
  Node
_                   -> []