imp-ppl-0.1.0.0: viz/Main.hs
module Main where
import Data.List (nub)
import qualified Data.IntMap.Strict as IntMap
import qualified Data.Map.Strict as Map
import Imp.BDD (VarLabel(..))
import Imp.BDD.Compile (compile)
import Imp.BDD.WMC (Weight(..))
import Imp.DSL (Imp)
import Imp.Inference (credalVertices, intervalExpectation, intervalProbability)
import Imp.Examples.Ellsberg as E
import Imp.Examples.IMDP as IMDP
import Imp.Examples.Iteration as Iter
import Imp.Examples.Knightian as K
import Imp.Examples.Polytope as P
import Viz
main :: IO ()
main = do
writeFile "index.html" page
putStrLn "Wrote index.html — open in a browser."
page :: String
page = htmlPage overviewSimplex figureEntries
[iterSection, ellsbergSection, imdpSection]
-- | The Figure 1 examples overlaid on one simplex.
overviewSimplex :: String
overviewSimplex = simplexSVG ("R", "G", "B")
[ CredalLayer "polytope (interval)" "#2E7D32" (bary3 (P.Red, P.Green, P.Blue) P.polytope)
, CredalLayer "independent (quadrilateral)" "#1565C0" (bary3 (K.Red, K.Green, K.Blue) K.independent)
, CredalLayer "dependent (line segment)" "#C62828" (bary3 (K.Red, K.Green, K.Blue) K.dependent)
]
figureEntries :: [VizEntry]
figureEntries =
[ VizEntry "dependent — 1 Knightian choice (line segment)"
srcDependent (mkBddSVG K.dependent)
, VizEntry "independent — 2 Knightian choices (quadrilateral)"
srcIndependent (mkBddSVG K.independent)
, VizEntry "polytope — composed intervals"
(srcPolytope ++ expectNote) (mkBddSVG P.polytope)
]
-- | Lower/upper expectation shown under the polytope snippet.
expectNote :: String
expectNote =
let (lo, hi) = intervalExpectation P.polytope
(\v -> case v of P.Red -> 1.0; P.Green -> 0.5; P.Blue -> 0.0)
in "\n-- E[f] for f(R)=1, f(G)=0.5, f(B)=0:\n-- E[f] \x2208 [" ++ showRound3 lo ++ ", " ++ showRound3 hi ++ "]"
iterSection :: String
iterSection =
let layer :: String -> String -> Imp g Int -> CredalLayer
layer name color walk =
let verts = credalVertices walk
label = name ++ ": " ++ show (length verts) ++ "\x2192"
++ show (nDistinct verts) ++ " distinct"
in CredalLayer label color (map (toBary3 (0, 1, 2) . capAt2) verts)
labels = ("0 (R)", "1 (G)", "\x2265 2 (B)")
simplexSym = simplexSVG labels
[ layer "walk3" "#6A1B9A" Iter.walk3
, layer "walk2" "#1565C0" Iter.walk2
, layer "walk1" "#C62828" Iter.walk1
]
simplexAsym = simplexSVG labels [layer "walk3Asym" "#E65100" Iter.walk3Asym]
in unlines
[ ""
, "<h2>Iteration — building up Knightian choices</h2>"
, "<p class=\"legend\">Random walk: at each step, move right with P ∈ [0.3, 0.7]."
, " Positions: 0 → R, 1 → G, ≥2 → B."
, " Each iteration adds a fresh Knightian name to the grade."
, " <code>intervalMap</code> is the graded <code>mapM</code>: it traverses"
, " a type-level list of names, giving each an independent interval choice.</p>"
, "<div class=\"row\">"
, "<div class=\"card\">"
, " <h3>Symmetric intervals — vertex collapse</h3>"
, " <p class=\"legend\">With identical intervals, swapping valuations (hi,lo) ↔ (lo,hi)"
, " gives the same distribution. 2<sup>n</sup> valuations → (n+1) distinct vertices.</p>"
, simplexSym
, " " ++ srcBlock srcWalk
, "</div>"
, "<div class=\"card\">"
, " <h3>Asymmetric intervals — no collapse</h3>"
, " <p class=\"legend\">Different interval widths break the symmetry."
, " All 8 valuations give distinct distributions."
, " Dots inside the shaded polygon are interior to the convex hull.</p>"
, simplexAsym
, " " ++ srcBlock srcWalkAsym
, "</div>"
, "</div>"
]
ellsbergSection :: String
ellsbergSection =
let simplex = simplexSVG ("Red", "Black", "Yellow")
[CredalLayer "ellsberg (line segment)" "#1565C0" (bary3 (E.Red, E.Black, E.Yellow) ellsberg)]
gambleRow (name, bet, event) =
let (lo, hi) = intervalProbability ellsberg event
precise = if hi - lo < 1e-9 then "<strong>Yes</strong>" else "No"
in " <tr><td>" ++ name ++ "</td><td>" ++ bet ++ "</td><td>["
++ showRound3 lo ++ ", " ++ showRound3 hi ++ "]</td><td>" ++ precise ++ "</td></tr>"
gambles =
[ ("I", "Red", (== E.Red))
, ("II", "Black", (== E.Black))
, ("III", "Red ∨ Yellow", \b -> b == E.Red || b == E.Yellow)
, ("IV", "Black ∨ Yellow", \b -> b == E.Black || b == E.Yellow)
]
in unlines $
[ ""
, "<h2>Textbook: Ellsberg paradox (1961)</h2>"
, "<p class=\"legend\">Urn with 90 balls: 30 Red (known), 60 Black or Yellow (unknown split)."
, " P(Red) = ⅓ is precise; P(Black) + P(Yellow) = ⅔ is precise;"
, " but individually P(Black) ∈ [0, ⅔] and P(Yellow) ∈ [0, ⅔].</p>"
, "<div class=\"row\">"
, "<div class=\"card\">"
, " <h3>Credal set on the simplex</h3>"
, simplex
, " " ++ srcBlock srcEllsberg
, "</div>"
, "<div class=\"card\">"
, " <h3>Gamble analysis</h3>"
, " <p class=\"legend\">Lower/upper expectations of the four Ellsberg gambles."
, " People prefer gambles with <em>precise</em> expectations (ambiguity aversion).</p>"
, " <table class=\"api\">"
, " <tr><th>Gamble</th><th>Bet on</th><th>E[win]</th><th>Precise?</th></tr>"
] ++ map gambleRow gambles ++
[ " </table>"
, " <p class=\"legend\">Preferring I over II <em>and</em> IV over III is inconsistent"
, " with any single prior, but consistent with the credal set.</p>"
, "</div>"
, "</div>"
]
imdpSection :: String
imdpSection =
let layer :: String -> String -> Imp g Position -> CredalLayer
layer name color robot = CredalLayer
(name ++ ": " ++ show (nDistinct (credalVertices robot)) ++ " distinct")
color (bary3 (P0, P1, P2) robot)
simplex = simplexSVG ("Start (0)", "Mid (1)", "Goal (2)")
[ layer "simpleRobot3" "#2E7D32" IMDP.simpleRobot3
, layer "simpleRobot" "#C62828" IMDP.simpleRobot
]
reachRow :: Int -> Imp g Position -> String -> String
reachRow n robot choices =
let (lo, hi) = intervalProbability robot (== P2)
in " <tr><td>" ++ show n ++ "</td><td>[" ++ showRound3 lo ++ ", "
++ showRound3 hi ++ "]</td><td>" ++ choices ++ "</td></tr>"
in unlines
[ ""
, "<h2>Interval MDP — robot navigation</h2>"
, "<p class=\"legend\">Robot at position 0 on {0, 1, 2}. At each step, moves right"
, " with P ∈ [0.6, 0.9]. Position 2 is absorbing (goal).</p>"
, "<div class=\"row\">"
, "<div class=\"card\">"
, " <h3>Credal sets (2 and 3 steps)</h3>"
, simplex
, " " ++ srcBlock srcRobot
, "</div>"
, "<div class=\"card\">"
, " <h3>Reachability analysis</h3>"
, " <p class=\"legend\">Lower/upper probability of reaching the goal (position 2).</p>"
, " <table class=\"api\">"
, " <tr><th>Steps</th><th>P(reach goal)</th><th>Knightian choices</th></tr>"
, reachRow 2 IMDP.simpleRobot "move1, move2"
, reachRow 3 IMDP.simpleRobot3 "move1, move2, move3"
, " </table>"
, " <p class=\"legend\">Symmetric intervals cause vertex collapse:"
, " with identical step intervals, (hi,lo) and (lo,hi) give the same distribution.</p>"
, "</div>"
, "</div>"
]
-- | Compile to one event BDD per value, render as SVG.
mkBddSVG :: (Ord a, Show a) => Imp g a -> String
mkBddSVG prog =
let (mgr, weights, knights, events) = compile prog
knightName = IntMap.fromList [ (i, name) | (name, i) <- Map.toList knights ]
names = Map.fromList $
[ (VarLabel k, knightName IntMap.! i) | (k, Knight i) <- IntMap.toList weights ] ++
[ (VarLabel k, "flip") | (k, Prob _) <- IntMap.toList weights ]
in bddSVG mgr names [ (show v, bdd) | (v, bdd) <- Map.toList events ]
-- | A program's credal-set vertices in barycentric coordinates.
bary3 :: Ord a => (a, a, a) -> Imp g a -> [(Double, Double, Double)]
bary3 keys prog = map (toBary3 keys) (credalVertices prog)
-- | Project a distribution onto barycentric coordinates for the
-- three given outcomes (missing outcomes get probability 0).
toBary3 :: Ord a => (a, a, a) -> Map.Map a Double -> (Double, Double, Double)
toBary3 (k1, k2, k3) dist =
( Map.findWithDefault 0 k1 dist
, Map.findWithDefault 0 k2 dist
, Map.findWithDefault 0 k3 dist )
-- | Merge all walk positions >= 2 so the distribution fits a 2-simplex.
capAt2 :: Map.Map Int Double -> Map.Map Int Double
capAt2 = Map.mapKeysWith (+) (min 2)
-- | Round a distribution's probabilities to 3 decimal places for comparison.
roundDist :: Map.Map a Double -> Map.Map a Double
roundDist = fmap (\v -> fromIntegral (round (v * 1000) :: Int) / 1000)
-- | Number of distinct distributions, up to rounding.
nDistinct :: Ord a => [Map.Map a Double] -> Int
nDistinct = length . nub . map roundDist
showRound3 :: Double -> String
showRound3 x = show (fromIntegral (round (x * 1000) :: Int) / 1000 :: Double)
-- Source snippets shown on the page, verbatim from Imp.Examples.*.
srcDependent :: String
srcDependent = unlines
[ "dependent :: Imp '[\"a1\"] Three"
, "dependent = Imp.do"
, " x <- flip 0.5"
, " if x then Imp.do"
, " y <- knight @\"a1\""
, " Imp.return (if y then Red else Green)"
, " else Imp.do"
, " y <- knight @\"a1\""
, " Imp.return (if y then Red else Blue)"
]
srcIndependent :: String
srcIndependent = unlines
[ "independent :: Imp '[\"a1\", \"a2\"] Three"
, "independent = Imp.do"
, " x <- flip 0.5"
, " if x then Imp.do"
, " y <- knight @\"a1\""
, " Imp.return (if y then Red else Green)"
, " else Imp.do"
, " y <- knight @\"a2\""
, " Imp.return (if y then Red else Blue)"
]
srcPolytope :: String
srcPolytope = unlines
[ "polytope :: Imp '[\"p\", \"q\"] Three"
, "polytope = Imp.do"
, " p <- interval @\"p\" 0.2 0.8"
, " q <- interval @\"q\" 0.3 0.7"
, " Imp.return $ if p then Red else (if q then Green else Blue)"
]
srcWalk :: String
srcWalk = unlines
[ "walk3 :: Imp '[\"s1\", \"s2\", \"s3\"] Int"
, "walk3 = Imp.do"
, " steps <- intervalMap @'[\"s1\", \"s2\", \"s3\"] 0.3 0.7"
, " Imp.return $ length (filter id steps)"
]
srcWalkAsym :: String
srcWalkAsym = unlines
[ "walk3Asym :: Imp '[\"s1\", \"s2\", \"s3\"] Int"
, "walk3Asym = Imp.do"
, " s1 <- interval @\"s1\" 0.1 0.9"
, " s2 <- interval @\"s2\" 0.3 0.7"
, " s3 <- interval @\"s3\" 0.45 0.55"
, " Imp.return $ length (filter id [s1, s2, s3])"
]
srcEllsberg :: String
srcEllsberg = unlines
[ "ellsberg :: Imp '[\"split\"] Ball"
, "ellsberg = Imp.do"
, " isRed <- flip (1/3)"
, " isBlack <- interval @\"split\" 0.0 1.0"
, " Imp.return $ if isRed then Red"
, " else (if isBlack then Black else Yellow)"
]
srcRobot :: String
srcRobot = unlines
[ "simpleRobot :: Imp '[\"move1\", \"move2\"] Position"
, "simpleRobot = Imp.do"
, " move1 <- interval @\"move1\" 0.6 0.9"
, " let pos1 = step P0 move1"
, " move2 <- interval @\"move2\" 0.6 0.9"
, " Imp.return (step pos1 move2)"
]