├── .gitignore
├── Makefile
├── bingo.ipkg
├── src
├── Control
│ └── ST
│ │ └── LiftEffect.idr
├── Effect
│ └── Random
│ │ └── Shuffle.idr
└── Bingo
│ ├── RichText.idr
│ ├── Main.idr
│ ├── Bingo.idr
│ └── Web.idr
├── README.md
└── index.html
/.gitignore:
--------------------------------------------------------------------------------
1 | *.ibc
2 | bingo.js
3 |
--------------------------------------------------------------------------------
/Makefile:
--------------------------------------------------------------------------------
1 | IDRIS = idris
2 | IPKG = bingo.ipkg
3 |
4 | .phony: build clean
5 |
6 | build:
7 | $(IDRIS) --build $(IPKG)
8 |
9 | clean:
10 | $(IDRIS) --clean $(IPKG)
11 |
--------------------------------------------------------------------------------
/bingo.ipkg:
--------------------------------------------------------------------------------
1 | package bingo
2 |
3 | sourcedir = src
4 |
5 | pkgs = contrib, js, effects
6 |
7 | executable = bingo.js
8 | main = Bingo.Main
9 | opts = "--codegen javascript"
10 |
--------------------------------------------------------------------------------
/src/Control/ST/LiftEffect.idr:
--------------------------------------------------------------------------------
1 | module Control.ST.LiftEffect
2 |
3 | import Control.ST
4 | import Effects
5 |
6 | %default total
7 |
8 | export liftEff : (Handler eff m, Monad m) => (var : Var) -> Eff a [MkEff x eff] -> ST m a [var ::: State x]
9 | liftEff var prog = do
10 | s <- read var
11 | (r ** [s']) <- lift $ runEnv [s] prog
12 | write var s'
13 | pure r
14 |
--------------------------------------------------------------------------------
/src/Effect/Random/Shuffle.idr:
--------------------------------------------------------------------------------
1 | module Effect.Random.Shuffle
2 |
3 | import Effects
4 | import Effect.Random
5 | import Data.Vect
6 |
7 | export shuffle : Vect n a -> Eff (Vect n a) [RND]
8 | shuffle [] = pure []
9 | shuffle {n = S n} xs@(x :: xs') = do
10 | k <- rndFin n
11 | let x' = index k xs
12 | let (_ :: xs') = replaceAt k x xs
13 | (x' ::) <$> shuffle xs'
14 |
--------------------------------------------------------------------------------
/README.md:
--------------------------------------------------------------------------------
1 | ICFP 2017 Bingo (Idris edition)
2 | ===============================
3 |
4 | I wrote the original implementation of the [ICFP 2017 Bingo][bingo] in
5 | Haskell using GHCJS and Reflex-DOM; however, the generated JavaScript
6 | weighed in at 2 MB, which is pretty bad considering how trivial this
7 | single-page webapp is.
8 |
9 | My friend and ex-coworker [Encsé][encse] mentioned I should give Idris a
10 | try, so I did. The resulting JavaScript is 150 kB, much better.
11 |
12 | Dependencies:
13 | -------------
14 |
15 | * [`idrisjs`][idrisjs] for interfacing with the DOM
16 | * `effects` for random number generation
17 | * `contrib` for ST as used by `idrisjs`
18 |
19 | [Live demo][demo]
20 | =================
21 |
22 | [bingo]: https://gergo.erdi.hu/projects/icfp-bingo-2017
23 | [encse]: https://csokavar.hu
24 | [idrisjs]: https://github.com/rbarreiro/idrisjs
25 | [demo]: https://gergo.erdi.hu/projects/icfp-bingo-2017/idr/
26 |
--------------------------------------------------------------------------------
/index.html:
--------------------------------------------------------------------------------
1 |
2 |
3 |
4 | ICFP Bingo 2018
5 |
9 |
28 |
29 |
30 |
31 |
32 |
33 |
34 |
35 |
--------------------------------------------------------------------------------
/src/Bingo/RichText.idr:
--------------------------------------------------------------------------------
1 | module Bingo.RichText
2 |
3 | import Js.Dom
4 |
5 | %default total
6 |
7 | data FragMode = Plain | Emph | Code
8 |
9 | plain : String -> Html ev
10 | plain = text
11 |
12 | emph : String -> Html ev
13 | emph = node "em" (the (List (HtmlAttribute _)) []) . pure . text
14 |
15 | code : String -> Html ev
16 | code = node "tt" (the (List (HtmlAttribute _)) []) . pure . text
17 |
18 | export parse : String -> List (Html ev)
19 | parse = finish . foldl step (Plain, [], []) . unpack
20 | where
21 | frag : FragMode -> List Char -> Html ev
22 | frag Plain = plain . pack . reverse
23 | frag Emph = emph . pack . reverse
24 | frag Code = code . pack . reverse
25 |
26 | step : (FragMode, List Char, List (Html ev)) -> Char -> (FragMode, List Char, List (Html ev))
27 | step (Plain, s, frags) '*' = (Emph, [], frag Plain s :: frags)
28 | step (Emph, s, frags) '*' = (Plain, [], frag Emph s :: frags)
29 | step (Plain, s, frags) '`' = (Code, [], frag Plain s :: frags)
30 | step (Code, s, frags) '`' = (Plain, [], frag Code s :: frags)
31 | step (mode, s, frags) c = (mode, c :: s, frags)
32 |
33 | finish : (FragMode, List Char, List (Html ev)) -> List (Html ev)
34 | finish (mode, overhang, frags) = reverse $ if isNil overhang then frags else frag mode overhang :: frags
35 |
--------------------------------------------------------------------------------
/src/Bingo/Main.idr:
--------------------------------------------------------------------------------
1 | module Main
2 |
3 | import Bingo.Web
4 | import Data.Vect
5 | import Js.Dom
6 |
7 | freeSpaces : List (Html Void)
8 | freeSpaces =
9 | [ square
10 | [ text "FREE "
11 | , node "strike" (the (List $ HtmlAttribute _) []) . pure . text $ "MONAD"
12 | , text " SPACE"
13 | ]
14 | , square
15 | [ text "FREE "
16 | , node "strike" (the (List $ HtmlAttribute _) []) . pure . text $ "ALGEBRA"
17 | , text " SPACE"
18 | ]
19 | ]
20 | where
21 | square : List (Html Void) -> Html Void
22 | square = node0 "td" [stringAttribute "style" "background: #ddd"]
23 |
24 | items : List String
25 | items =
26 | [ "Generalization of monads"
27 | , "`Nat` as an inductive type"
28 | , "`fac` as a recursive function"
29 | , "`Vec` as an indexed type"
30 | , "Session type that receives a list"
31 | , "Linear types"
32 | , "One slide with ≥3 type derivation rules"
33 | , "A type system has undecidable type checking"
34 | , "Algebraic effects"
35 | , "Universe codes"
36 | , "Ornaments"
37 | , "Phil Wadler asks a question"
38 | , "SPJ, from the audience, answers a question"
39 | , "Insertion sort is proven correct"
40 | , "Proof relevance"
41 | , "Quotient types"
42 | , "JavaScript (non-sarcastically)"
43 | , "Shirt joke"
44 | , "Hoare triplets"
45 | , "DSL"
46 | , "FRP"
47 | , "HoTT"
48 | , "Static tracking of computational cost"
49 | , "`reverse` as a tail-recursive function w/accumulator"
50 | , "Pi-calculus"
51 | , "SMT solvers"
52 | , "Row polymorphism"
53 | , "Symbolic execution"
54 | , "Gradual typing"
55 | ]
56 |
57 | main : JS_IO ()
58 | main = runPage (fromList freeSpaces) (fromList items)
59 |
--------------------------------------------------------------------------------
/src/Bingo/Bingo.idr:
--------------------------------------------------------------------------------
1 | module Bingo.Bingo
2 |
3 | import Data.Vect
4 |
5 | %default total
6 |
7 | public export data IsEven : Nat -> Nat -> Type where
8 | Times2 : (n : Nat) -> IsEven (n + n) n
9 |
10 | public export data IsOdd : Nat -> Nat -> Type where
11 | Times2Plus1 : (n : Nat) -> IsOdd (S (n + n)) n
12 |
13 | public export total parity : (n : Nat) -> Either (Exists (IsEven n)) (Exists (IsOdd n))
14 | parity Z = Left $ Evidence _ $ Times2 0
15 | parity (S Z) = Right $ Evidence _ $ Times2Plus1 0
16 | parity (S (S n)) = case parity n of
17 | Left (Evidence _ (Times2 k)) =>
18 | Left $ rewrite plusSuccRightSucc k k in Evidence _ $ Times2 (S k)
19 | Right (Evidence _ (Times2Plus1 k)) =>
20 | Right $ rewrite plusSuccRightSucc k k in Evidence _ $ Times2Plus1 (S k)
21 |
22 | export data Bingo : Nat -> Type -> Type where
23 | Even : IsEven n k -> Vect (n * n) a -> Bingo n a
24 | Odd : IsOdd n k -> a -> Vect (2 * (k * n + k)) a -> Bingo n a
25 |
26 | public export BingoArg : Nat -> Type -> Type
27 | BingoArg n a with (parity n)
28 | BingoArg _ a | Left (Evidence _ (Times2 k)) = let n = k + k in Vect (n * n) a
29 | BingoArg _ a | Right (Evidence _ (Times2Plus1 k)) = let n = 1 + k + k in (a, Vect (2 * (k * n + k)) a)
30 |
31 | export mkBingo : (n : Nat) -> BingoArg n a -> Bingo n a
32 | mkBingo n arg with (parity n)
33 | mkBingo _ xs | Left (Evidence k (Times2 k)) = Even (Times2 k) xs
34 | mkBingo _ (x, xs) | Right (Evidence k (Times2Plus1 k)) = Odd (Times2Plus1 k) x xs
35 |
36 | toMatrix : (n : Nat) -> (m : Nat) -> Vect (n * m) a -> Vect n (Vect m a)
37 | toMatrix Z _ [] = []
38 | toMatrix (S n) m xs = let (ys, yss) = splitAt m xs in ys :: toMatrix n m yss
39 |
40 | mult2 : (n : Nat) -> n + n = 2 * n
41 | mult2 n = rewrite plusZeroRightNeutral n in Refl
42 |
43 | export grid : Bingo n a -> Vect n (Vect n a)
44 | grid (Even prf xs) = toMatrix _ _ xs
45 | grid (Odd {n = S (k + k)} (Times2Plus1 k) free xs) =
46 | let (before, after) = splitAt (k * n + k) xs in
47 | toMatrix _ _ (rewrite lemma in before ++ [free] ++ after)
48 | where
49 | n : Nat
50 | n = S (k + k)
51 |
52 | lemma: n * n = ((k * n) + k) + (1 + (((k * n) + k) + 0))
53 | lemma = sym $ -- ((k * n) + k) + (1 + ((k * n) + k) + 0) =
54 | rewrite plusZeroRightNeutral ((k * n) + k) in -- ((k * n) + k) + (1 + (k * n) + k) =
55 | rewrite plusAssociative ((k * n) + k) 1 ((k * n) + k) in -- (((k * n) + k) + 1) + (k * n) + k) =
56 | rewrite plusCommutative ((k * n) + k) 1 in -- 1 + ((k * n) + k)) + ((k * n) + k) =
57 | rewrite mult2 ((k * n) + k) in -- 1 + 2 * ((k * n) + k) =
58 | rewrite multDistributesOverPlusRight 2 (k * n) k in -- 1 + 2 * (k * n) + 2 * k
59 | rewrite multAssociative 2 k n in -- 1 + (2 * k) * n + 2 * k =
60 | rewrite sym (mult2 k) in -- 1 + (k + k) * n + (k + k) =
61 | rewrite plusCommutative ((k + k) * n) (k + k) in -- (k + k) * n + (1 + k + k) =
62 | -- (k + k) * n + n =
63 | -- (1 + k + k) * n =
64 | -- n * n
65 | Refl
66 |
--------------------------------------------------------------------------------
/src/Bingo/Web.idr:
--------------------------------------------------------------------------------
1 | module Bingo.Web
2 |
3 | import Bingo.RichText
4 | import Bingo.Bingo
5 |
6 | import Js.Dom
7 | import Control.ST
8 | import Control.ST.ImplicitCall
9 | import Effects
10 | import Effect.Random
11 | import Effect.Random.Shuffle
12 | import Control.ST.LiftEffect
13 |
14 |
15 | export node0 : String -> List (HtmlAttribute ev) -> List (Html ev) -> Html ev
16 | node0 = node
17 |
18 | total table : Vect n (Vect m (Html ev)) -> Html ev
19 | table xs = node0 "table" [cssClass "table table-bordered"] [node0 "tbody" [] $ toList $ map row xs]
20 | where
21 | row : Vect m (Html ev) -> Html ev
22 | row = node0 "tr" [stringAttribute "style" "height: 12ex"] . toList
23 |
24 | public export BingoSize : Nat
25 | BingoSize = 5
26 |
27 | BingoSheet : Type
28 | BingoSheet = Bingo BingoSize (Html Void)
29 |
30 | data Command = Shuffle | Print
31 |
32 | toBingo : Html Void -> Vect (BingoSize * BingoSize + _) String -> BingoSheet
33 | toBingo freeSpace items = mkBingo BingoSize (freeSpace, map (node0 "td" [] . parse) $ take (BingoSize * BingoSize - 1) items)
34 |
35 | Gui : (Dom m) => Type
36 | Gui {m} = DomRef {m} () (const BingoSheet) (const Command) ()
37 |
38 | render : () -> BingoSheet -> Html Command
39 | render () spaces = div [stringAttribute "style" "width: 100%; max-width: 600px; margin: auto"]
40 | [ div [] [map void $ table $ grid spaces]
41 | , button [onclick Shuffle, cssClass "btn btn-lg noprint btn-default"]
42 | "Give me another one"
43 | , button [onclick Print, cssClass "btn btn-lg noprint btn-primary pull-right"]
44 | "Print"
45 | ]
46 |
47 | printPage : ST ASync () []
48 | printPage = lift . liftJS_IO $ jscall "window.print()" (JS_IO ())
49 |
50 |
51 | makeSheet
52 | : Vect (S _) (Html Void)
53 | -> Vect (BingoSize * BingoSize + _) String
54 | -> (seed : Var)
55 | -> ST ASync BingoSheet [seed ::: State Integer]
56 | makeSheet freeSpaces items seed = do
57 | items' <- call $ liftEff seed $ shuffle items
58 | freeSpace <- call $ liftEff seed $ rndSelect' freeSpaces
59 | pure $ toBingo freeSpace items'
60 |
61 | exec
62 | : Vect (S _) (Html Void)
63 | -> Vect (BingoSize * BingoSize + _) String
64 | -> (dom : Var)
65 | -> (seed : Var)
66 | -> Command
67 | -> ST ASync () [seed ::: State Integer, dom ::: Gui {m = ASync}]
68 | exec freeSpaces items dom seed cmd = case cmd of
69 | Shuffle => do
70 | sheet <- makeSheet freeSpaces items seed
71 | domPut dom sheet
72 | Print => do
73 | printPage
74 |
75 | pageLoop
76 | : Vect (S _) (Html Void)
77 | -> Vect (BingoSize * BingoSize + _) String
78 | -> (dom : Var)
79 | -> (seed : Var)
80 | -> ST ASync () [seed ::: State Integer, dom ::: Gui {m = ASync}]
81 | pageLoop freeSpaces items dom seed = do
82 | cmd <- getInput dom
83 | exec freeSpaces items dom seed cmd
84 | pageLoop freeSpaces items dom seed
85 |
86 | page : Vect (S _) (Html Void) -> Vect (BingoSize * BingoSize + _) String -> ST ASync () []
87 | page freeSpaces items = do
88 | seed <- do
89 | now <- lift . liftJS_IO $ jscall "new Date().getTime()" (JS_IO Int)
90 | new $ cast now
91 | dom <- do
92 | sheet <- makeSheet freeSpaces items seed
93 | initBody [] render () sheet
94 |
95 | pageLoop freeSpaces items dom seed
96 |
97 | clearDom dom
98 | delete seed
99 |
100 | export runPage : Vect (S _) (Html Void) -> Vect (BingoSize * BingoSize + _) String -> JS_IO ()
101 | runPage freeSpaces items = setASync_ $ run $ page freeSpaces items
102 |
--------------------------------------------------------------------------------