├── .gitignore ├── LICENSE ├── README.md ├── Setup.hs ├── default.nix ├── examples ├── loop.png ├── loop.svg ├── minimal.png ├── minimal.svg ├── pi.png ├── pi.svg ├── rev.png └── rev.svg ├── hs ├── lib │ └── Turnstyle │ │ ├── Compile.hs │ │ ├── Compile │ │ ├── Bound.hs │ │ ├── Constraint.hs │ │ ├── Contaminate.hs │ │ ├── Expr.hs │ │ ├── Paint.hs │ │ ├── Recompile.hs │ │ ├── Shake.hs │ │ ├── Shape.hs │ │ ├── SimulatedAnnealing.hs │ │ └── Solve.hs │ │ ├── Eval.hs │ │ ├── Expr.hs │ │ ├── Image.hs │ │ ├── JuicyPixels.hs │ │ ├── Main.hs │ │ ├── Number.hs │ │ ├── Parse.hs │ │ ├── Prim.hs │ │ ├── Quattern.hs │ │ ├── Scale.hs │ │ ├── Text.hs │ │ ├── Text │ │ ├── Parse.hs │ │ ├── Pretty.hs │ │ └── Sugar.hs │ │ └── TwoD.hs ├── src │ ├── AnnotateExamples.hs │ ├── Main.hs │ ├── Recolor.hs │ ├── SpecFigures.hs │ └── Website.hs └── test │ ├── Main.hs │ └── Turnstyle │ ├── Compile │ └── Tests.hs │ ├── Eval │ └── Tests.hs │ ├── Expr │ └── Tests.hs │ ├── Parse │ └── Tests.hs │ ├── Quattern │ └── Tests.hs │ └── Text │ └── Tests.hs ├── shell.nix ├── spec ├── README.md ├── app.svg ├── cheatsheet.svg ├── enter.svg ├── id.svg ├── init.svg ├── label.svg ├── lam.svg ├── symbol.svg └── var.svg ├── turnstyle.cabal ├── turnstyle.js └── website ├── favicon.ico ├── home.md ├── playground.html ├── preview.png ├── preview.svg ├── style.css ├── template.html └── turnstyle.svg /.gitignore: -------------------------------------------------------------------------------- 1 | /.stack-work 2 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # ⊢ Turnstyle 2 | 3 | Turnstyle is a graphical esoteric programming language. For more information on 4 | the language, see . 5 | 6 | This repository holds: 7 | 8 | - The reference implementation in Haskell 9 | - A JavaScript implementation that works in the browser 10 | - The turnstyle website 11 | - An experimental compiler 12 | 13 | ## Local development 14 | 15 | You need a Haskell installation to build this repository. The recommended way 16 | to do that is to use [GHCup](https://www.haskell.org/ghcup/). 17 | 18 | - Running a program: `cabal run turnstyle run FOO.PNG` 19 | - Run the website: `cabal run turnstyle-website preview` 20 | - Running the tests: `cabal test` 21 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /default.nix: -------------------------------------------------------------------------------- 1 | let pkgs = import {}; 2 | in pkgs.haskellPackages.callCabal2nix "turnstyle" ./. {} 3 | -------------------------------------------------------------------------------- /examples/loop.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jaspervdj/turnstyle/f7054f1b9a3c0fdb311b0721bde96ba846971450/examples/loop.png -------------------------------------------------------------------------------- /examples/loop.svg: -------------------------------------------------------------------------------- 1 | 2 | 4 | -------------------------------------------------------------------------------- /examples/minimal.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jaspervdj/turnstyle/f7054f1b9a3c0fdb311b0721bde96ba846971450/examples/minimal.png -------------------------------------------------------------------------------- /examples/minimal.svg: -------------------------------------------------------------------------------- 1 | 2 | 4 | -------------------------------------------------------------------------------- /examples/pi.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jaspervdj/turnstyle/f7054f1b9a3c0fdb311b0721bde96ba846971450/examples/pi.png -------------------------------------------------------------------------------- /examples/rev.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jaspervdj/turnstyle/f7054f1b9a3c0fdb311b0721bde96ba846971450/examples/rev.png -------------------------------------------------------------------------------- /examples/rev.svg: -------------------------------------------------------------------------------- 1 | 2 | 4 | -------------------------------------------------------------------------------- /hs/lib/Turnstyle/Compile.hs: -------------------------------------------------------------------------------- 1 | module Turnstyle.Compile 2 | ( CompileOptions (..) 3 | , defaultCompileOptions 4 | 5 | , CompileError (..) 6 | , SolveError (..) 7 | 8 | , compile 9 | ) where 10 | 11 | import qualified Codec.Picture as JP 12 | import Data.Bifunctor (first) 13 | import Data.Either.Validation (Validation (..)) 14 | import Data.Foldable (toList) 15 | import Data.List.NonEmpty (NonEmpty (..)) 16 | import qualified Data.Map as M 17 | import Data.Ord (Down (..)) 18 | import Data.Void (Void) 19 | import System.Random (mkStdGen) 20 | import Turnstyle.Compile.Bound 21 | import qualified Turnstyle.Compile.Contaminate as Contaminate 22 | import Turnstyle.Compile.Expr 23 | import Turnstyle.Compile.Paint 24 | import Turnstyle.Compile.Shake 25 | import Turnstyle.Compile.Shape 26 | import qualified Turnstyle.Compile.SimulatedAnnealing as SA 27 | import Turnstyle.Compile.Solve 28 | import qualified Turnstyle.Expr as E 29 | import Turnstyle.JuicyPixels (JuicyPixels) 30 | import Turnstyle.Parse (Ann, ParseError, 31 | parseImage) 32 | import qualified Turnstyle.Text.Sugar as S 33 | import Turnstyle.TwoD 34 | 35 | data CompileOptions = CompileOptions 36 | { coImports :: M.Map FilePath JuicyPixels 37 | , coOptimize :: Bool 38 | , coSeed :: Int 39 | , coBudget :: Int 40 | , coHillClimb :: Bool 41 | , coRestarts :: Int 42 | } 43 | 44 | defaultCompileOptions :: CompileOptions 45 | defaultCompileOptions = CompileOptions M.empty False 12345 2000 False 5 46 | 47 | data CompileError ann 48 | = UnboundVars (NonEmpty (ann, String)) 49 | | UnknownImport ann FilePath 50 | | BadImport ann FilePath (NonEmpty (Ann, ParseError)) 51 | | SolveError (SolveError Pos) 52 | deriving (Show) 53 | 54 | compile 55 | :: CompileOptions -> S.Sugar Void ann 56 | -> Either (CompileError ann) (JP.Image JP.PixelRGBA8) 57 | compile _ expr | err : errs <- checkVars expr = do 58 | Left $ UnboundVars (err :| errs) 59 | compile opts expr = do 60 | expr0 <- fromSugar (\ann attrs path -> case M.lookup path (coImports opts) of 61 | Nothing -> Left $ UnknownImport ann path 62 | Just jp -> case E.checkErrors (parseImage Nothing jp) of 63 | Success e -> pure $ Import attrs jp e 64 | Failure err -> Left $ BadImport ann path err) expr 65 | 66 | let palette = 67 | let contaminated = Contaminate.palette expr0 in 68 | toList contaminated ++ 69 | filter (not . (`elem` contaminated)) defaultPalette 70 | 71 | neighbour l g = case shake l g of 72 | Just (l', g') 73 | | Right _ <- solve palette $ sConstraints (exprToShape l') -> 74 | (l', g') 75 | _ -> (l, g) 76 | 77 | expr1 78 | | not (coOptimize opts) = expr0 79 | | otherwise = fst $ withRestarts 80 | (coRestarts opts) 81 | (Down . scoreLayout) 82 | (case coHillClimb opts of 83 | True -> hillWalk 84 | (coBudget opts) 85 | (Down . scoreLayout) 86 | neighbour 87 | False -> SA.run 88 | SA.defaultOptions 89 | { SA.oGiveUp = Just (coBudget opts) 90 | , SA.oScore = fromIntegral . negate . scoreLayout 91 | , SA.oNeighbour = neighbour 92 | }) 93 | expr0 (mkStdGen (coSeed opts)) 94 | shape = exprToShape expr1 95 | colors <- first SolveError (solve palette $ sConstraints shape) 96 | pure $ paint colors shape 97 | 98 | scoreLayout :: Ord v => Expr v -> Int 99 | scoreLayout expr = 100 | let shape = exprToShape expr in 101 | -- Minimize area 102 | 2 * (sWidth shape + sHeight shape) + 103 | -- Try to get a square 104 | abs (sWidth shape - sHeight shape) + 105 | -- Align entrance near center 106 | 4 * abs (sHeight shape `div` 2 - sEntrance shape) 107 | 108 | withRestarts 109 | :: Ord n 110 | => Int 111 | -> (a -> n) 112 | -> (a -> g -> (a, g)) 113 | -> a -> g -> (a, g) 114 | withRestarts n score f x0 g0 = 115 | let (x1, g1) = f x0 g0 in 116 | go 0 x1 (score x1) g1 117 | where 118 | go i best bestScore gen0 119 | | i >= n = (best, gen0) 120 | | nextScore >= bestScore = go (i + 1) next nextScore gen1 121 | | otherwise = go (i + 1) best bestScore gen1 122 | where 123 | (next, gen1) = f x0 gen0 124 | nextScore = score next 125 | 126 | hillWalk 127 | :: Ord n 128 | => Int 129 | -> (a -> n) 130 | -> (a -> g -> (a, g)) 131 | -> a -> g -> (a, g) 132 | hillWalk maxSteps score step start = go 0 start (score start) start 133 | where 134 | go steps best bestScore current gen0 135 | | steps >= maxSteps = (best, gen0) 136 | | nextScore >= bestScore = go (steps + 1) next nextScore next gen1 137 | | otherwise = go (steps + 1) best bestScore best gen1 138 | where 139 | (next, gen1) = step current gen0 140 | nextScore = score next 141 | -------------------------------------------------------------------------------- /hs/lib/Turnstyle/Compile/Bound.hs: -------------------------------------------------------------------------------- 1 | module Turnstyle.Compile.Bound 2 | ( checkVars 3 | ) where 4 | 5 | import Data.Foldable (toList) 6 | import qualified Data.Set as S 7 | import Turnstyle.Text.Sugar 8 | 9 | -- | Checks that all variables are bound. 10 | checkVars :: Sugar err ann -> [(ann, String)] 11 | checkVars = go S.empty 12 | where 13 | go vars (Let _ v d b) = go vars d <> go (S.insert v vars) b 14 | go _ (Import _ _ _) = [] 15 | go vars (App _ f xs) = go vars f <> foldMap (go vars) xs 16 | go vars (Lam _ vs b) = go (vars <> S.fromList (toList vs)) b 17 | go vars (Var ann v) = if S.member v vars then [] else [(ann, v)] 18 | go _ (Prim _ _) = [] 19 | go _ (Lit _ _) = [] 20 | go _ (Err _ _) = [] 21 | -------------------------------------------------------------------------------- /hs/lib/Turnstyle/Compile/Constraint.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFoldable #-} 2 | {-# LANGUAGE DeriveFunctor #-} 3 | module Turnstyle.Compile.Constraint 4 | ( ColorConstraint (..) 5 | ) where 6 | 7 | data ColorConstraint c p 8 | = Eq p p 9 | | NotEq p p 10 | | LitEq c p 11 | deriving (Foldable, Functor, Show) 12 | -------------------------------------------------------------------------------- /hs/lib/Turnstyle/Compile/Contaminate.hs: -------------------------------------------------------------------------------- 1 | module Turnstyle.Compile.Contaminate 2 | ( palette 3 | ) where 4 | 5 | 6 | import qualified Codec.Picture as JP 7 | import Control.Monad (guard) 8 | import qualified Data.Set as S 9 | import Turnstyle.Compile.Expr 10 | import Turnstyle.Image 11 | import Turnstyle.JuicyPixels 12 | 13 | palette :: Expr v -> S.Set (Pixel JuicyPixels) 14 | palette (Import as img _) | ("contaminate", "true") `elem` as = S.fromList $ do 15 | y <- [0 .. height img - 1] 16 | x <- [0 .. width img - 1] 17 | let p@(JP.PixelRGBA8 _ _ _ alpha) = pixel x y img 18 | guard $ alpha /= 0 19 | pure p 20 | palette (Import _ _ _) = mempty 21 | palette (App _ f x) = palette f <> palette x 22 | palette (Lam _ _ b) = palette b 23 | palette (Var _) = mempty 24 | palette (Prim _) = mempty 25 | palette (Lit _ _) = mempty 26 | -------------------------------------------------------------------------------- /hs/lib/Turnstyle/Compile/Expr.hs: -------------------------------------------------------------------------------- 1 | module Turnstyle.Compile.Expr 2 | ( AppLayout (..) 3 | , LamLayout (..) 4 | , LitLayout (..) 5 | , Expr (..) 6 | , fromExpr 7 | , fromSugar 8 | ) where 9 | 10 | import Data.Default (Default (..)) 11 | import Data.Void (Void, absurd) 12 | import qualified Turnstyle.Expr as E 13 | import Turnstyle.Image (Pixel) 14 | import Turnstyle.JuicyPixels (JuicyPixels) 15 | import Turnstyle.Parse (Ann) 16 | import Turnstyle.Prim 17 | import qualified Turnstyle.Text.Sugar as S 18 | 19 | data AppLayout 20 | = AppLeftRight 21 | | AppLeftFront 22 | | AppFrontRight 23 | deriving (Eq, Show) 24 | 25 | instance Default AppLayout where def = AppLeftRight 26 | 27 | data LamLayout 28 | = LamLeft 29 | | LamRight 30 | | LamStraight 31 | deriving (Eq, Show) 32 | 33 | instance Default LamLayout where def = LamLeft 34 | 35 | data LitLayout = LitLayout Int Int deriving (Eq, Show) 36 | 37 | instance Default LitLayout where def = LitLayout 0 0 38 | 39 | data Expr v 40 | = Import S.Attributes JuicyPixels (E.Expr Ann Void (Pixel JuicyPixels)) 41 | | App AppLayout (Expr v) (Expr v) 42 | | Lam LamLayout v (Expr v) 43 | | Var v 44 | | Prim Prim 45 | | Lit LitLayout Integer 46 | 47 | fromExpr :: E.Expr ann Void v -> Expr v 48 | fromExpr (E.App _ f x) = App def (fromExpr f) (fromExpr x) 49 | fromExpr (E.Lam _ v b) = Lam def v (fromExpr b) 50 | fromExpr (E.Var _ v) = Var v 51 | fromExpr (E.Prim _ p) = Prim p 52 | fromExpr (E.Lit _ l) = Lit def l 53 | fromExpr (E.Id _ e) = fromExpr e 54 | fromExpr (E.Err _ e) = absurd e 55 | 56 | fromSugar 57 | :: Monad m 58 | => (ann -> S.Attributes -> FilePath -> m (Expr String)) 59 | -> S.Sugar Void ann -> m (Expr String) 60 | fromSugar imports (S.Let _ v d b) = do 61 | d' <- fromSugar imports d 62 | b' <- fromSugar imports b 63 | pure $ App def (Lam def v b') d' 64 | fromSugar imports (S.Import ann attrs fp) = imports ann attrs fp 65 | fromSugar imports (S.App _ f xs) = do 66 | f' <- fromSugar imports f 67 | xs' <- traverse (fromSugar imports) xs 68 | pure $ foldl (App def) f' xs' 69 | fromSugar imports (S.Lam _ vs b) = do 70 | b' <- fromSugar imports b 71 | pure $ foldr (Lam def) b' vs 72 | fromSugar _ (S.Var _ v) = pure $ Var v 73 | fromSugar _ (S.Prim _ p) = pure $ Prim p 74 | fromSugar _ (S.Lit _ l) = pure $ Lit def l 75 | fromSugar _ (S.Err _ e) = absurd e 76 | -------------------------------------------------------------------------------- /hs/lib/Turnstyle/Compile/Paint.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | module Turnstyle.Compile.Paint 3 | ( paint 4 | , defaultPalette 5 | ) where 6 | 7 | import qualified Codec.Picture as JP 8 | import Data.List (transpose) 9 | import Data.Maybe (fromMaybe) 10 | import Turnstyle.Compile.Shape 11 | import Turnstyle.TwoD 12 | 13 | defaultPalette :: [JP.PixelRGBA8] 14 | defaultPalette = concat $ transpose 15 | [ [JP.PixelRGBA8 c 0 0 255 | c <- steps] 16 | , [JP.PixelRGBA8 0 c 0 255 | c <- steps] 17 | , [JP.PixelRGBA8 0 0 c 255 | c <- steps] 18 | , [JP.PixelRGBA8 c c 0 255 | c <- steps] 19 | , [JP.PixelRGBA8 0 c c 255 | c <- steps] 20 | , [JP.PixelRGBA8 c 0 c 255 | c <- steps] 21 | , [JP.PixelRGBA8 c r 0 255 | (c, r) <- zip steps (reverse steps)] 22 | , [JP.PixelRGBA8 0 c r 255 | (c, r) <- zip steps (reverse steps)] 23 | , [JP.PixelRGBA8 c 0 r 255 | (c, r) <- zip steps (reverse steps)] 24 | ] 25 | where 26 | steps = reverse [31, 63 .. 255] 27 | 28 | paint 29 | :: (Pos -> Maybe JP.PixelRGBA8) -> Shape 30 | -> JP.Image JP.PixelRGBA8 31 | paint colors s = JP.generateImage 32 | (\x0 y0 -> fromMaybe background $ 33 | let x1 = x0 - offsetX 34 | y1 = y0 - offsetY in 35 | if x1 >= 0 && x1 < sWidth s && y1 >= 0 && y1 < sHeight s 36 | then colors (Pos x1 y1) 37 | else Nothing) 38 | (sWidth s) 39 | (spacingHeight * 2 + 1) 40 | where 41 | topHeight = sEntrance s 42 | bottomHeight = sHeight s - sEntrance s - 1 43 | spacingHeight = max topHeight bottomHeight 44 | offsetX = 0 45 | offsetY = spacingHeight - sEntrance s 46 | background = JP.PixelRGBA8 0 0 0 0 47 | -------------------------------------------------------------------------------- /hs/lib/Turnstyle/Compile/Recompile.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | module Turnstyle.Compile.Recompile 4 | ( recompile 5 | ) where 6 | 7 | import qualified Data.Map as M 8 | import qualified Data.Set as S 9 | import Data.Void (Void) 10 | import Turnstyle.Compile.Constraint 11 | import Turnstyle.Expr 12 | import Turnstyle.Image 13 | import Turnstyle.Parse 14 | import Turnstyle.Quattern (Quattern (..)) 15 | import Turnstyle.TwoD 16 | 17 | recompile 18 | :: forall img c. (Image img, Ord (Pixel img)) 19 | => img -> Expr Ann Void (Pixel img) -> [ColorConstraint c Pos] 20 | recompile img = exprToConstraints img S.empty M.empty 21 | 22 | exprToConstraints 23 | :: forall img c. (Image img, Ord (Pixel img)) 24 | => img 25 | -> S.Set Ann 26 | -> M.Map (Pixel img) Pos 27 | -> Expr Ann Void (Pixel img) 28 | -> [ColorConstraint c Pos] 29 | exprToConstraints img visited ctx expr 30 | | ann `S.member` visited = [] 31 | | otherwise = constraints ++ children 32 | where 33 | ann = getAnn expr 34 | visited' = S.insert ann visited 35 | children = case expr of 36 | Lam _ _ b -> exprToConstraints img visited' ctx' b 37 | App _ lhs rhs -> 38 | exprToConstraints img visited' ctx' lhs ++ 39 | exprToConstraints img visited' ctx' rhs 40 | Id _ e -> exprToConstraints img visited' ctx' e 41 | _ -> [] 42 | 43 | relPixel rel = let (Pos px py) = relPos pos dir rel in pixel px py img 44 | (pos, dir, quattern) = ann 45 | 46 | ctx' = case quattern of 47 | AABC -> M.insert (relPixel RightPos) r ctx 48 | ABCB -> M.insert (relPixel LeftPos) l ctx 49 | ABBC -> M.insert (relPixel CenterPos) c ctx 50 | _ -> ctx 51 | 52 | constraints = case quattern of 53 | AAAA -> [Eq l c, Eq l f, Eq l r] 54 | AAAB -> [Eq l c, Eq l f, NotEq l r] ++ 55 | [Eq (ctx M.! relPixel RightPos) r] 56 | AABA -> [Eq l c, NotEq l f, Eq l r] ++ 57 | [Eq (ctx M.! relPixel FrontPos) f] 58 | AABB -> [Eq l c, NotEq l f, Eq f r] 59 | AABC -> [Eq l c, NotEq l f, NotEq l r, NotEq f r] 60 | ABAA -> [NotEq l c, Eq l f, Eq l r] ++ 61 | [Eq (ctx M.! relPixel CenterPos) c] 62 | ABAB -> [NotEq l c, Eq l f, Eq c r] 63 | ABAC -> [NotEq l c, Eq l f, NotEq l r, NotEq c r] 64 | ABBA -> [NotEq l c, Eq c f, Eq l r] 65 | ABBB -> [NotEq l c, Eq c f, Eq c r] ++ 66 | [Eq (ctx M.! relPixel LeftPos) l] 67 | ABBC -> [NotEq l c, Eq c f, NotEq l r, NotEq c r] 68 | ABCA -> [NotEq l c, NotEq l f, NotEq c f, Eq l r] 69 | ABCB -> [NotEq l c, NotEq l f, NotEq c f, Eq c r] 70 | ABCC -> [NotEq l c, NotEq l f, NotEq c f, Eq f r] 71 | ABCD -> 72 | [NotEq l c, NotEq l f, NotEq c f, NotEq l r, NotEq c r, NotEq f r] ++ 73 | contiguousConstrains l ++ 74 | contiguousConstrains f ++ 75 | contiguousConstrains r 76 | 77 | l = relPos pos dir LeftPos 78 | c = relPos pos dir CenterPos 79 | f = relPos pos dir FrontPos 80 | r = relPos pos dir RightPos 81 | 82 | contiguousConstrains p = 83 | let inside = contiguous p img 84 | border = S.fromList $ 85 | filter (not . (`S.member` inside)) $ 86 | concatMap neighbors (S.toList inside) in 87 | [Eq p i | i <- S.toList inside, i /= p] ++ 88 | [NotEq p b | b <- S.toList border] 89 | 90 | -------------------------------------------------------------------------------- /hs/lib/Turnstyle/Compile/Shake.hs: -------------------------------------------------------------------------------- 1 | module Turnstyle.Compile.Shake 2 | ( shake 3 | ) where 4 | 5 | import Data.Foldable (toList) 6 | import Data.List.NonEmpty (NonEmpty (..)) 7 | import System.Random (RandomGen, uniformR) 8 | import Turnstyle.Compile.Expr 9 | 10 | shakeOnce 11 | :: (Expr v -> [Expr v]) 12 | -> Expr v -> [NonEmpty (Expr v)] 13 | shakeOnce shakeChild = go id 14 | where 15 | go mkExpr expr = 16 | (case mkExpr <$> shakeChild expr of 17 | [] -> [] 18 | c : cs -> [c :| cs]) ++ 19 | case expr of 20 | Import _ _ _ -> [] 21 | App ann f x -> 22 | go (\f' -> mkExpr (App ann f' x)) f ++ 23 | go (\x' -> mkExpr (App ann f x')) x 24 | Lam ann v b -> 25 | go (\b' -> mkExpr (Lam ann v b')) b 26 | Var _ -> [] 27 | Prim _ -> [] 28 | Lit _ _ -> [] 29 | 30 | shakeExpr :: Expr v -> [Expr v] 31 | shakeExpr (App AppLeftRight f x) = [App l f x | l <- [AppLeftFront, AppFrontRight]] 32 | shakeExpr (App AppLeftFront f x) = [App l f x | l <- [AppLeftRight, AppFrontRight]] 33 | shakeExpr (App AppFrontRight f x) = [App l f x | l <- [AppLeftRight, AppLeftFront]] 34 | shakeExpr (Lam LamLeft v b) = [Lam l v b | l <- [LamRight, LamStraight]] 35 | shakeExpr (Lam LamRight v b) = [Lam l v b | l <- [LamLeft, LamStraight]] 36 | shakeExpr (Lam LamStraight v b) = [Lam l v b | l <- [LamLeft, LamRight]] 37 | shakeExpr (Lit (LitLayout u d) l) = 38 | [Lit (LitLayout u' d) l | u' <- [u - 1, u + 1], u' >= 0, u' + d <= fromIntegral l] ++ 39 | [Lit (LitLayout u d') l | d' <- [d - 1, d + 1], d' >= 0, u + d' <= fromIntegral l] 40 | shakeExpr _ = [] 41 | 42 | shake :: RandomGen g => Expr v -> g -> Maybe (Expr v, g) 43 | shake expr0 gen0 = case shakeOnce shakeExpr expr0 of 44 | [] -> Nothing 45 | once -> 46 | let (onceIdx, gen1) = uniformR (0, length once - 1) gen0 47 | child = toList $ once !! onceIdx 48 | (childIdx, gen2) = uniformR (0, length child - 1) gen1 in 49 | Just (child !! childIdx, gen2) 50 | -------------------------------------------------------------------------------- /hs/lib/Turnstyle/Compile/SimulatedAnnealing.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE RecordWildCards #-} 3 | module Turnstyle.Compile.SimulatedAnnealing 4 | ( Options (..) 5 | , defaultOptions 6 | 7 | , run 8 | ) where 9 | 10 | import System.Random (RandomGen, randomR) 11 | 12 | data Options g a = Options 13 | { oScore :: a -> Double 14 | , oNeighbour :: a -> g -> (a, g) 15 | , oQuit :: a -> Bool 16 | , oTemperature :: Double 17 | , oCooling :: Double 18 | , oGiveUp :: Maybe Int -- ^ Restart if no improvement for n iterations 19 | } 20 | 21 | defaultOptions :: Options g a 22 | defaultOptions = Options 23 | { oScore = \_ -> 0 24 | , oNeighbour = (,) 25 | , oQuit = \_ -> False 26 | , oTemperature = 60 27 | , oCooling = 0.9999 28 | , oGiveUp = Just 200000 29 | } 30 | 31 | run :: RandomGen g => Options g a -> a -> g -> (a, g) 32 | run Options {..} = \initial gen -> 33 | let initialScore = oScore initial in 34 | go oTemperature (initial, initialScore) (initial, initialScore) 0 gen 35 | where 36 | go temperature b@(best, bestScore) c@(current, currentScore) !stuck gen0 37 | | oQuit current = (current, gen0) 38 | | maybe False (stuck >=) oGiveUp = (best, gen0) 39 | | otherwise = 40 | let (new, gen1) = oNeighbour current gen0 41 | !newScore = oScore new 42 | 43 | (accept, gen2) = p currentScore newScore temperature gen1 44 | 45 | n@(_next, nextScore) 46 | | accept = (new, newScore) 47 | | otherwise = c 48 | 49 | (stuck', b') 50 | | nextScore > bestScore = (0, n) 51 | | otherwise = (stuck + 1, b) in 52 | 53 | go (temperature * oCooling) b' n stuck' gen2 54 | 55 | p e e' temp gen0 56 | | e' >= e = (True, gen0) 57 | | otherwise = 58 | let prob = exp (negate (e - e') / temp) 59 | (rand, gen1) = randomR (0, 1) gen0 in 60 | (rand < prob, gen1) 61 | -------------------------------------------------------------------------------- /hs/lib/Turnstyle/Compile/Solve.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | module Turnstyle.Compile.Solve 3 | ( SolveError (..) 4 | , solve 5 | ) where 6 | 7 | import Control.Monad (foldM, when) 8 | import Data.Foldable (toList) 9 | import qualified Data.Graph as G 10 | import Data.List (foldl') 11 | import qualified Data.Map as M 12 | import Data.Maybe (maybeToList) 13 | import qualified Data.Set as S 14 | import Turnstyle.Compile.Shape 15 | 16 | type Graph v = M.Map v (S.Set v) 17 | 18 | addEdge :: Ord v => v -> v -> Graph v -> Graph v 19 | addEdge p q = 20 | M.insertWith S.union p (S.singleton q) . 21 | M.insertWith S.union q (S.singleton p) 22 | 23 | newtype Component p = Component Int deriving (Eq, Ord) 24 | 25 | data SolveError p 26 | = Inconsistent p p 27 | | UnknownVertex p 28 | | NotEnoughColors deriving (Show) 29 | 30 | solve 31 | :: forall p c. (Ord p, Eq c) 32 | => [c] 33 | -> [ColorConstraint c p] 34 | -> Either (SolveError p) (p -> Maybe c) 35 | solve palette constraints = do 36 | ineqGraph <- mkInequalityGraph 37 | colors <- greedyColor ineqGraph 38 | pure $ \p -> M.lookup p vertexToComponent >>= (`M.lookup` colors) 39 | where 40 | vertices :: S.Set p 41 | vertices = foldMap S.singleton (constraints >>= toList) 42 | 43 | equalities, inequalities :: [(p, p)] 44 | equalities = [(p, q) | Eq p q <- constraints] 45 | inequalities = [(p, q) | NotEq p q <- constraints] 46 | 47 | equalityGraph :: Graph p 48 | equalityGraph = foldl' 49 | (\acc (p, q) -> addEdge p q acc) 50 | (M.fromSet (const S.empty) vertices) 51 | equalities 52 | 53 | components :: [(Component p, G.SCC p)] 54 | components = zip [Component i | i <- [0 ..]] $ G.stronglyConnComp 55 | [(p, p, S.toList qs) | (p, qs) <- M.toList equalityGraph] 56 | 57 | vertexToComponent :: M.Map p (Component p) 58 | vertexToComponent = M.fromList 59 | [(p, c) | (c, gc) <- components, p <- toList gc] 60 | 61 | mkInequalityGraph :: Either (SolveError p) (Graph (Component p)) 62 | mkInequalityGraph = foldM 63 | (\acc (p, q) -> do 64 | pc <- maybe (Left $ UnknownVertex p) pure $ M.lookup p vertexToComponent 65 | qc <- maybe (Left $ UnknownVertex q) pure $ M.lookup q vertexToComponent 66 | when (pc == qc) $ Left $ Inconsistent p q 67 | pure $ addEdge pc qc acc) 68 | M.empty 69 | inequalities 70 | 71 | initialColors :: M.Map (Component p) c 72 | initialColors = M.fromList $ do 73 | LitEq col p <- constraints 74 | comp <- maybeToList $ M.lookup p vertexToComponent 75 | pure (comp, col) 76 | 77 | greedyColor 78 | :: M.Map (Component p) (S.Set (Component p)) 79 | -> Either (SolveError p) (M.Map (Component p) c) 80 | greedyColor inequalityGraph = foldM 81 | (\acc c -> do 82 | let unavailable = do 83 | nc <- maybe [] S.toList $ M.lookup c inequalityGraph 84 | maybeToList $ M.lookup nc acc 85 | color <- case filter (not . (`elem` unavailable)) palette of 86 | [] -> Left NotEnoughColors 87 | col : _ -> pure col 88 | pure $ M.insert c color acc) 89 | initialColors 90 | (filter (not . (`M.member` initialColors)) $ fst <$> components) 91 | -------------------------------------------------------------------------------- /hs/lib/Turnstyle/Eval.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeApplications #-} 2 | module Turnstyle.Eval 3 | ( EvalException (..) 4 | , MonadEval (..) 5 | 6 | , Var (..) 7 | , Whnf (..) 8 | , whnf 9 | , eval 10 | ) where 11 | 12 | import Control.Exception (Exception, IOException, handle, throwIO) 13 | import Data.Char (chr, ord) 14 | import qualified Data.Set as S 15 | import qualified Turnstyle.Expr as Expr 16 | import Turnstyle.Expr (Expr) 17 | import Turnstyle.Number 18 | import Turnstyle.Prim 19 | 20 | data Type 21 | = ApplicationTy 22 | | LambdaTy 23 | | VariableTy 24 | | PrimitiveTy 25 | | NumberTy 26 | | IntegralTy 27 | | ErrorTy 28 | deriving (Eq) 29 | 30 | instance Show Type where 31 | show ApplicationTy = "function application" 32 | show LambdaTy = "lambda" 33 | show VariableTy = "variable" 34 | show PrimitiveTy = "primitive" 35 | show NumberTy = "number" 36 | show IntegralTy = "integral" 37 | show ErrorTy = "error" 38 | 39 | data EvalException 40 | = PrimBadArg Prim Int Type Type 41 | | DivideByZero 42 | deriving (Eq) 43 | 44 | instance Show EvalException where 45 | show (PrimBadArg p n expected actual) = 46 | "primitive " ++ primName p ++ " bad argument #" ++ show n ++ 47 | ": expected " ++ show expected ++ " but got " ++ show actual 48 | show DivideByZero = "division by zero" 49 | 50 | instance Exception EvalException 51 | 52 | class Monad m => MonadEval m where 53 | evalThrow :: EvalException -> m a 54 | evalInputNumber :: m (Maybe Integer) 55 | evalInputChar :: m (Maybe Char) 56 | evalOutputNumber :: Number -> m () 57 | evalOutputChar :: Char -> m () 58 | 59 | instance MonadEval IO where 60 | evalThrow = throwIO 61 | 62 | evalInputNumber = handle @IOException (\_ -> pure Nothing) (Just <$> readLn) 63 | evalInputChar = handle @IOException (\_ -> pure Nothing) (Just <$> getChar) 64 | 65 | evalOutputNumber = print 66 | evalOutputChar = putChar 67 | 68 | eval :: (MonadEval m, Ord v) => Expr ann err v -> m (Whnf ann err v) 69 | eval = whnf . fmap User 70 | 71 | data Var v = User v | Fresh Int deriving (Eq, Ord, Show) 72 | 73 | -- | An expression in WHNF. 74 | data Whnf ann err v 75 | = App (Whnf ann err v) (Expr ann err (Var v)) 76 | | Lam (Var v) (Expr ann err (Var v)) 77 | | Var (Var v) 78 | | UnsatPrim Int Prim [Expr ann err (Var v)] 79 | | Lit Number 80 | | Err ann err 81 | deriving (Eq, Show) 82 | 83 | whnf :: (Ord v, MonadEval m) => Expr ann err (Var v) -> m (Whnf ann err v) 84 | whnf (Expr.App ann f x) = do 85 | fv <- whnf f 86 | case fv of 87 | Lam v body -> whnf (subst v x body) 88 | UnsatPrim 1 p args -> prim ann p (reverse (x : args)) 89 | UnsatPrim n p args -> pure $ UnsatPrim (n - 1) p (x : args) 90 | _ -> pure $ App fv x 91 | whnf (Expr.Lam _ v body) = pure $ Lam v body 92 | whnf (Expr.Var _ v) = pure $ Var v 93 | whnf (Expr.Prim _ p) = pure $ UnsatPrim (primArity p) p [] 94 | whnf (Expr.Lit _ lit) = pure $ Lit $ fromIntegral lit 95 | whnf (Expr.Id _ e) = whnf e 96 | whnf (Expr.Err ann err) = pure $ Err ann err 97 | 98 | subst 99 | :: Ord v 100 | => Var v -> Expr ann e (Var v) -> Expr ann e (Var v) -> Expr ann e (Var v) 101 | subst x s b = sub b 102 | where 103 | sub e@(Expr.Var _ v) 104 | | v == x = s 105 | | otherwise = e 106 | sub e@(Expr.Lam ann v e') 107 | | v == x = e 108 | | v `S.member` fvs = Expr.Lam ann v' (sub e'') 109 | | otherwise = Expr.Lam ann v (sub e') 110 | where 111 | v' = head $ filter (`S.notMember` vs) [Fresh n | n <- [0 ..]] 112 | e'' = subst v (Expr.Var ann v') e' 113 | sub (Expr.App ann f a) = Expr.App ann (sub f) (sub a) 114 | sub e@(Expr.Lit _ _) = e 115 | sub e@(Expr.Prim _ _) = e 116 | sub (Expr.Id ann e) = Expr.Id ann (sub e) 117 | sub e@(Expr.Err _ _) = e 118 | 119 | fvs = Expr.freeVars s 120 | vs = fvs <> Expr.allVars b 121 | 122 | prim 123 | :: (Ord v, MonadEval m) 124 | => ann -> Prim -> [Expr ann err (Var v)] -> m (Whnf ann err v) 125 | prim ann (PIn inMode) [k, l] = do 126 | mbLit <- case inMode of 127 | InNumber -> evalInputNumber 128 | InChar -> fmap (fromIntegral . ord) <$> evalInputChar 129 | case mbLit of 130 | Nothing -> whnf l 131 | Just lit -> whnf $ Expr.App ann k $ Expr.Lit ann lit 132 | prim _ p@(POut outMode) [outE, kE] = do 133 | out <- whnf outE >>= castArgNumber p 1 134 | case outMode of 135 | OutNumber -> evalOutputNumber out 136 | OutChar -> case numberToInt out of 137 | Nothing -> evalThrow $ PrimBadArg p 1 IntegralTy NumberTy 138 | Just n -> evalOutputChar $ chr n 139 | whnf kE 140 | prim _ p@(PNumOp numOp) [xE, yE] = do 141 | x <- whnf xE >>= castArgNumber p 1 142 | y <- whnf yE >>= castArgNumber p 2 143 | fmap Lit $ case numOp of 144 | NumOpAdd -> pure $ x + y 145 | NumOpSubtract -> pure $ x - y 146 | NumOpDivide | y == 0 -> evalThrow DivideByZero 147 | NumOpDivide -> pure $ x / y 148 | NumOpMultiply -> pure $ x * y 149 | NumOpModulo -> do 150 | xi <- maybe (evalThrow (PrimBadArg p 1 IntegralTy NumberTy)) pure $ numberToInteger x 151 | yi <- maybe (evalThrow (PrimBadArg p 1 IntegralTy NumberTy)) pure $ numberToInteger y 152 | pure $ fromInteger $ xi `mod` yi 153 | prim _ p@(PCompare cmp) [xE, yE, fE, gE] = do 154 | x <- whnf xE >>= castArgNumber p 1 155 | y <- whnf yE >>= castArgNumber p 2 156 | case cmp of 157 | CmpEq -> if x == y then whnf fE else whnf gE 158 | CmpLessThan -> if x < y then whnf fE else whnf gE 159 | CmpGreaterThan -> if x > y then whnf fE else whnf gE 160 | CmpLessThanOrEqual -> if x <= y then whnf fE else whnf gE 161 | CmpGreaterThanOrEqual -> if x >= y then whnf fE else whnf gE 162 | prim _ p@(PInexact InexactSqrt) [xE] = do 163 | x <- whnf xE >>= castArgNumber p 1 164 | pure . Lit . Inexact . sqrt $ numberToDouble x 165 | 166 | castArgNumber :: MonadEval m => Prim -> Int -> Whnf ann err v -> m Number 167 | castArgNumber p narg e = case e of 168 | Lit x -> pure x 169 | _ -> evalThrow $ PrimBadArg p narg NumberTy (typeOf e) 170 | 171 | typeOf :: Whnf err ann v -> Type 172 | typeOf (App _ _) = ApplicationTy 173 | typeOf (Lam _ _) = LambdaTy 174 | typeOf (Var _) = VariableTy 175 | typeOf (UnsatPrim _ _ _) = PrimitiveTy 176 | typeOf (Lit _) = NumberTy 177 | typeOf (Err _ _) = ErrorTy 178 | -------------------------------------------------------------------------------- /hs/lib/Turnstyle/Expr.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFoldable #-} 2 | {-# LANGUAGE DeriveFunctor #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | module Turnstyle.Expr 5 | ( Expr (..) 6 | , getAnn 7 | , mapAnn 8 | , mapErr 9 | , freeVars 10 | , allVars 11 | , normalizeVars 12 | , checkCycles 13 | , checkErrors 14 | ) where 15 | 16 | import Control.Monad.State (State, evalState, state) 17 | import Data.Either.Validation (Validation (..)) 18 | import Data.List.NonEmpty (NonEmpty (..)) 19 | import qualified Data.Map as M 20 | import qualified Data.Set as S 21 | import Data.Void (Void) 22 | import Turnstyle.Prim 23 | 24 | data Expr ann e v 25 | = App ann (Expr ann e v) (Expr ann e v) 26 | | Lam ann v (Expr ann e v) 27 | | Var ann v 28 | | Prim ann Prim 29 | | Lit ann Integer 30 | | Id ann (Expr ann e v) 31 | | Err ann e 32 | deriving (Eq, Foldable, Functor, Show) 33 | 34 | getAnn :: Expr a e v -> a 35 | getAnn (App ann _ _) = ann 36 | getAnn (Lam ann _ _) = ann 37 | getAnn (Var ann _) = ann 38 | getAnn (Prim ann _) = ann 39 | getAnn (Lit ann _) = ann 40 | getAnn (Id ann _) = ann 41 | getAnn (Err ann _) = ann 42 | 43 | mapAnn :: (a -> b) -> Expr a e v -> Expr b e v 44 | mapAnn m (App ann f x) = App (m ann) (mapAnn m f) (mapAnn m x) 45 | mapAnn m (Lam ann v b) = Lam (m ann) v (mapAnn m b) 46 | mapAnn m (Var ann v) = Var (m ann) v 47 | mapAnn m (Prim ann p) = Prim (m ann) p 48 | mapAnn m (Lit ann l) = Lit (m ann) l 49 | mapAnn m (Id ann e) = Id (m ann) (mapAnn m e) 50 | mapAnn m (Err ann err) = Err (m ann) err 51 | 52 | mapErr :: (err0 -> err1) -> Expr ann err0 v -> Expr ann err1 v 53 | mapErr m (App ann f x) = App ann (mapErr m f) (mapErr m x) 54 | mapErr m (Lam ann v b) = Lam ann v (mapErr m b) 55 | mapErr _ (Var ann v) = Var ann v 56 | mapErr _ (Prim ann p) = Prim ann p 57 | mapErr _ (Lit ann l) = Lit ann l 58 | mapErr m (Id ann e) = Id ann (mapErr m e) 59 | mapErr m (Err ann err) = Err ann (m err) 60 | 61 | -- | Free variables in an expression. 62 | freeVars :: Ord v => Expr ann e v -> S.Set v 63 | freeVars (App _ f x) = freeVars f <> freeVars x 64 | freeVars (Lam _ v body) = S.delete v $ freeVars body 65 | freeVars (Var _ v) = S.singleton v 66 | freeVars (Prim _ _) = S.empty 67 | freeVars (Lit _ _) = S.empty 68 | freeVars (Id _ e) = freeVars e 69 | freeVars (Err _ _) = S.empty 70 | 71 | -- | All variables in an expression. 72 | allVars :: Ord v => Expr ann e v -> S.Set v 73 | allVars = foldMap S.singleton 74 | 75 | -- | Only works if all variables are bound. 76 | normalizeVars :: forall ann e v. Ord v => Expr ann e v -> Expr ann e Int 77 | normalizeVars expr = evalState (go expr) (0, M.empty) 78 | where 79 | go :: Expr ann e v -> State (Int, M.Map v Int) (Expr ann e Int) 80 | go (App ann f x) = App ann <$> go f <*> go x 81 | go (Lam ann v b) = Lam ann <$> var v <*> go b 82 | go (Var ann v) = Var ann <$> var v 83 | go (Prim ann p) = pure $ Prim ann p 84 | go (Lit ann l) = pure $ Lit ann l 85 | go (Id ann e) = Id ann <$> go e 86 | go (Err ann e) = pure $ Err ann e 87 | 88 | var :: v -> State (Int, M.Map v Int) Int 89 | var v = state $ \(fresh, vars) -> case M.lookup v vars of 90 | Nothing -> (fresh, (fresh + 1, M.insert v fresh vars)) 91 | Just n -> (n, (fresh, vars)) 92 | 93 | -- | Finds cyclic expressions by using comparison on the annotation, assuming 94 | -- this represents some sort of position. 95 | checkCycles 96 | :: Ord ann 97 | => (Expr ann e v -> e) -- ^ Construct cyclic error 98 | -> Expr ann e v -- ^ Expression to check 99 | -> Expr ann e v -- ^ Expression with additional errors 100 | checkCycles mkError = go S.empty 101 | where 102 | go visited expr = case expr of 103 | _ | ann `S.member` visited -> Err ann (mkError expr) 104 | App _ f x -> App ann (go visited' f) (go visited' x) 105 | Lam _ v b -> Lam ann v $ go visited' b 106 | Id _ e -> Id ann (go visited' e) 107 | _ -> expr 108 | where 109 | ann = getAnn expr 110 | visited' = S.insert ann visited 111 | 112 | -- | Removes errors from an expression. 113 | checkErrors 114 | :: Ord ann 115 | => Expr ann e v -> Validation (NonEmpty (ann, e)) (Expr ann Void v) 116 | checkErrors = \expr -> case collect S.empty expr of 117 | [] -> Success $ unsafeErr expr 118 | err : errs -> Failure (err :| errs) 119 | where 120 | collect visited expr = case expr of 121 | Err _ e -> [(ann, e)] 122 | _ | ann `S.member` visited -> [] 123 | App _ f x -> collect visited' f ++ collect visited' x 124 | Lam _ _ b -> collect visited' b 125 | Var _ _ -> [] 126 | Prim _ _ -> [] 127 | Lit _ _ -> [] 128 | Id _ e -> collect visited' e 129 | where 130 | ann = getAnn expr 131 | visited' = S.insert ann visited 132 | 133 | unsafeErr (App ann f x) = App ann (unsafeErr f) (unsafeErr x) 134 | unsafeErr (Lam ann v b) = Lam ann v (unsafeErr b) 135 | unsafeErr (Var ann v) = Var ann v 136 | unsafeErr (Prim ann p) = Prim ann p 137 | unsafeErr (Lit ann l) = Lit ann l 138 | unsafeErr (Id ann e) = Id ann (unsafeErr e) 139 | unsafeErr (Err _ _) = error "checkErrors: error left after check" 140 | -------------------------------------------------------------------------------- /hs/lib/Turnstyle/Image.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies #-} 2 | module Turnstyle.Image 3 | ( Image (..) 4 | ) where 5 | 6 | class Image img where 7 | type Pixel img 8 | width :: img -> Int 9 | height :: img -> Int 10 | pixel :: Int -> Int -> img -> Pixel img 11 | -------------------------------------------------------------------------------- /hs/lib/Turnstyle/JuicyPixels.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies #-} 2 | module Turnstyle.JuicyPixels 3 | ( JuicyPixels (..) 4 | , Image 5 | , loadImage 6 | ) where 7 | 8 | import qualified Codec.Picture as JP 9 | 10 | import Turnstyle.Image (Image (..)) 11 | 12 | newtype JuicyPixels = JuicyPixels (JP.Image JP.PixelRGBA8) 13 | 14 | instance Image JuicyPixels where 15 | type Pixel JuicyPixels = JP.PixelRGBA8 16 | width (JuicyPixels img) = JP.imageWidth img 17 | height (JuicyPixels img) = JP.imageHeight img 18 | pixel x y (JuicyPixels img) = JP.pixelAt img x y 19 | 20 | loadImage :: FilePath -> IO JuicyPixels 21 | loadImage path = 22 | JP.readImage path >>= 23 | either fail (pure . JuicyPixels . JP.convertRGBA8) 24 | -------------------------------------------------------------------------------- /hs/lib/Turnstyle/Main.hs: -------------------------------------------------------------------------------- 1 | module Turnstyle.Main 2 | ( main 3 | ) where 4 | 5 | import qualified Codec.Picture as JP 6 | import Data.Foldable (for_, toList) 7 | import qualified Data.Map as M 8 | import Data.Maybe (fromMaybe) 9 | import Data.Traversable (for) 10 | import qualified Options.Applicative as OA 11 | import qualified System.IO as IO 12 | import Text.Read (readMaybe) 13 | import qualified Turnstyle.Compile as Compile 14 | import Turnstyle.Eval (eval) 15 | import Turnstyle.Expr 16 | import Turnstyle.JuicyPixels (loadImage) 17 | import Turnstyle.Parse 18 | import Turnstyle.Scale (autoScale) 19 | import qualified Turnstyle.Text as Text 20 | 21 | data Options = Options 22 | { oCommand :: Command 23 | } deriving (Show) 24 | 25 | data Command 26 | = Run RunOptions 27 | | Compile CompileOptions 28 | deriving (Show) 29 | 30 | data RunOptions = RunOptions 31 | { roInitialPosition :: Maybe Pos 32 | , roFilePath :: FilePath 33 | } deriving (Show) 34 | 35 | data CompileOptions = CompileOptions 36 | { coOptimize :: Bool 37 | , coSeed :: Maybe Int 38 | , coOut :: Maybe FilePath 39 | , coFilePath :: FilePath 40 | } deriving (Show) 41 | 42 | parseOptions :: OA.Parser Options 43 | parseOptions = Options 44 | <$> OA.subparser 45 | (OA.command "run" 46 | (OA.info (Run <$> parseRunOptions) 47 | (OA.progDesc "Run turnstyle program")) <> 48 | OA.command "compile" 49 | (OA.info (Compile <$> parseCompileOptions) 50 | (OA.progDesc "Compile lambda expression to image"))) 51 | 52 | parseRunOptions :: OA.Parser RunOptions 53 | parseRunOptions = RunOptions 54 | <$> OA.optional (OA.option (OA.eitherReader parsePos) 55 | (OA.long "initial-position" <> OA.metavar "X,Y" )) 56 | <*> OA.argument OA.str (OA.metavar "IMAGE.PNG") 57 | where 58 | parsePos :: String -> Either String Pos 59 | parsePos str = maybe (Left "invalid position") Right $ 60 | case break (== ',') str of 61 | (x, ',' : y) -> Pos <$> readMaybe x <*> readMaybe y 62 | _ -> Nothing 63 | 64 | parseCompileOptions :: OA.Parser CompileOptions 65 | parseCompileOptions = CompileOptions 66 | <$> OA.switch (OA.long "optimize" <> OA.short 'O') 67 | <*> OA.optional (OA.option OA.auto (OA.long "seed" <> OA.metavar "SEED")) 68 | <*> OA.optional (OA.strOption 69 | (OA.long "out" <> OA.short 'o' <> OA.metavar "IMAGE.PNG")) 70 | <*> OA.argument OA.str (OA.metavar "PROGRAM.TXT") 71 | 72 | data Error 73 | = ParseError ParseError 74 | | CycleError 75 | deriving (Show) 76 | 77 | main :: IO () 78 | main = do 79 | args <- OA.execParser opts 80 | case oCommand args of 81 | Run ropts -> do 82 | for_ [IO.stdin, IO.stdout, IO.stderr] $ \h -> 83 | IO.hSetBuffering h IO.LineBuffering 84 | img <- loadImage $ roFilePath ropts 85 | let expr = parseImage (roInitialPosition ropts) (autoScale img) 86 | putStrLn $ Text.prettyExpr $ checkCycles (const CycleError) $ 87 | mapErr ParseError expr 88 | eval expr >>= print 89 | Compile copts -> do 90 | let out = fromMaybe "a.png" (coOut copts) 91 | contents <- readFile $ coFilePath copts 92 | case Text.parseSugar (coFilePath copts) contents of 93 | Left err -> IO.hPutStrLn IO.stderr $ show err 94 | Right sugar -> do 95 | putStrLn $ Text.prettySugar sugar 96 | imports <- for (toList $ Text.sugarImports sugar) $ \p -> do 97 | img <- loadImage p 98 | putStrLn $ "Loaded " ++ p 99 | pure (p, img) 100 | let compileOptions = Compile.defaultCompileOptions 101 | { Compile.coImports = M.fromList imports 102 | , Compile.coOptimize = coOptimize copts 103 | } 104 | case Compile.compile compileOptions sugar of 105 | Left cerr -> IO.hPutStrLn IO.stderr $ show cerr 106 | Right img -> JP.savePngImage out $ JP.ImageRGBA8 img 107 | where 108 | opts = OA.info (parseOptions OA.<**> OA.helper) 109 | (OA.fullDesc <> OA.progDesc "Turnstyle") 110 | -------------------------------------------------------------------------------- /hs/lib/Turnstyle/Number.hs: -------------------------------------------------------------------------------- 1 | module Turnstyle.Number 2 | ( Number (..) 3 | , numberToDouble 4 | , numberToInteger 5 | , numberToInt 6 | ) where 7 | 8 | import Data.Ratio (denominator, numerator) 9 | 10 | data Number = Exact Rational | Inexact Double 11 | 12 | instance Show Number where 13 | show n = case n of 14 | _ | Just i <- numberToInteger n -> show i 15 | Exact x -> show (numerator x) ++ " / " ++ show (denominator x) 16 | Inexact x -> show x 17 | 18 | numberToDouble :: Number -> Double 19 | numberToDouble (Inexact x) = x 20 | numberToDouble (Exact x) = fromRational x 21 | 22 | numberToInteger :: Number -> Maybe Integer 23 | numberToInteger (Exact x) 24 | | denominator x == 1 = Just (numerator x) 25 | | otherwise = Nothing 26 | numberToInteger (Inexact x) 27 | | abs (fromIntegral rounded - x) <= 0.00001 = Just rounded 28 | | otherwise = Nothing 29 | where 30 | rounded = round x 31 | 32 | numberToInt :: Number -> Maybe Int 33 | numberToInt = fmap fromIntegral . numberToInteger 34 | 35 | unNumber :: (Rational -> a) -> (Double -> a) -> Number -> a 36 | unNumber exact _ (Exact x) = exact x 37 | unNumber _ inexact (Inexact x) = inexact x 38 | {-# INLINE unNumber #-} 39 | 40 | binop 41 | :: (Rational -> Rational -> a) 42 | -> (Double -> Double -> a) 43 | -> Number -> Number -> a 44 | binop exact inexact = go 45 | where 46 | go (Exact x) (Exact y) = exact x y 47 | go (Inexact x) y = inexact x (numberToDouble y) 48 | go x (Inexact y) = inexact (numberToDouble x) y 49 | {-# INLINE binop #-} 50 | 51 | instance Eq Number where 52 | (==) = binop (==) (==) 53 | 54 | instance Ord Number where 55 | (<=) = binop (<=) (<=) 56 | 57 | instance Num Number where 58 | (+) = binop (\x y -> Exact $ x + y) (\x y -> Inexact $ x + y) 59 | (*) = binop (\x y -> Exact $ x * y) (\x y -> Inexact $ x * y) 60 | (-) = binop (\x y -> Exact $ x - y) (\x y -> Inexact $ x - y) 61 | 62 | negate = unNumber (Exact . negate) (Inexact . negate) 63 | abs = unNumber (Exact . abs ) (Inexact . abs ) 64 | signum = unNumber (Exact . signum) (\x -> Exact $ if x < 0 then -1 else 1) 65 | 66 | fromInteger = Exact . fromInteger 67 | 68 | instance Fractional Number where 69 | (/) = binop (\x y -> Exact $ x / y) (\x y -> Inexact $ x / y) 70 | fromRational = Exact 71 | -------------------------------------------------------------------------------- /hs/lib/Turnstyle/Parse.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | module Turnstyle.Parse 5 | ( Ann 6 | , Dir (..) 7 | , Pos (..) 8 | , ParseError (..) 9 | , parseImage 10 | 11 | , RelPos (..) 12 | , relPos 13 | , contiguous 14 | 15 | , initialPosition 16 | ) where 17 | 18 | import qualified Data.Set as S 19 | import GHC.Exception (Exception) 20 | import Turnstyle.Expr 21 | import Turnstyle.Image 22 | import Turnstyle.Prim 23 | import Turnstyle.Quattern (Quattern (..), quattern) 24 | import Turnstyle.TwoD 25 | 26 | inside :: Image img => Pos -> img -> Bool 27 | inside (Pos x y) img = x >= 0 && x < width img && y >= 0 && y < height img 28 | 29 | initialPosition :: Image img => img -> Maybe Pos 30 | initialPosition img 31 | | width img <= 0 || height img <= 0 = Nothing 32 | | otherwise = Just $ Pos 0 (height img `div` 2) 33 | 34 | -- | Selecting single pixel from the turnstyle: 35 | -- 36 | -- L 37 | -- CF 38 | -- R 39 | -- 40 | data RelPos = LeftPos | CenterPos | FrontPos | RightPos deriving (Eq, Show) 41 | 42 | relPos :: Pos -> Dir -> RelPos -> Pos 43 | relPos (Pos x y) _ CenterPos = Pos (x ) (y ) 44 | relPos (Pos x y) R LeftPos = Pos (x ) (y - 1) 45 | relPos (Pos x y) R FrontPos = Pos (x + 1) (y ) 46 | relPos (Pos x y) R RightPos = Pos (x ) (y + 1) 47 | relPos (Pos x y) D LeftPos = Pos (x + 1) (y ) 48 | relPos (Pos x y) D FrontPos = Pos (x ) (y + 1) 49 | relPos (Pos x y) D RightPos = Pos (x - 1) (y ) 50 | relPos (Pos x y) L LeftPos = Pos (x ) (y + 1) 51 | relPos (Pos x y) L FrontPos = Pos (x - 1) (y ) 52 | relPos (Pos x y) L RightPos = Pos (x ) (y - 1) 53 | relPos (Pos x y) U LeftPos = Pos (x - 1) (y ) 54 | relPos (Pos x y) U FrontPos = Pos (x ) (y - 1) 55 | relPos (Pos x y) U RightPos = Pos (x + 1) (y ) 56 | 57 | type Ann = (Pos, Dir, Quattern) 58 | 59 | data ParseError 60 | = OutOfBounds 61 | | EmptyImage 62 | | UnknownSym Int 63 | | UnknownPrim Int Int 64 | deriving (Eq, Show) 65 | 66 | instance Exception ParseError 67 | 68 | parse 69 | :: forall img. (Image img, Eq (Pixel img), Show (Pixel img)) 70 | => Pos -> Dir -> img -> Expr Ann ParseError (Pixel img) 71 | parse pos dir img = case pattern of 72 | _ | not (inside (relPos pos dir LeftPos) img) -> Err ann OutOfBounds 73 | _ | not (inside (relPos pos dir CenterPos) img) -> Err ann OutOfBounds 74 | _ | not (inside (relPos pos dir FrontPos) img) -> Err ann OutOfBounds 75 | _ | not (inside (relPos pos dir RightPos) img) -> Err ann OutOfBounds 76 | 77 | -- App 78 | ABCA -> App ann parseLeft parseRight 79 | ABAC -> App ann parseLeft parseFront 80 | ABCC -> App ann parseFront parseRight 81 | 82 | -- Lam 83 | AABC -> Lam ann (relPixel RightPos) parseLeft 84 | ABCB -> Lam ann (relPixel LeftPos) parseRight 85 | ABBC -> Lam ann (relPixel CenterPos) parseFront 86 | 87 | -- Var 88 | ABAA -> Var ann $ relPixel CenterPos 89 | AABA -> Var ann $ relPixel FrontPos 90 | AAAB -> Var ann $ relPixel RightPos 91 | ABBB -> Var ann $ relPixel LeftPos 92 | 93 | -- Int/Prim 94 | ABCD -> case areaLeft of 95 | 1 -> Lit ann $ (fromIntegral areaFront :: Integer) ^ areaRight 96 | 2 -> case decodePrim areaFront areaRight of 97 | Nothing -> Err ann $ UnknownPrim areaFront areaRight 98 | Just prim -> Prim ann prim 99 | _ -> Err ann $ UnknownSym areaLeft 100 | 101 | -- Id 102 | AAAA -> Id ann $ parseFront 103 | ABBA -> Id ann $ parseFront 104 | AABB -> Id ann $ parseLeft 105 | ABAB -> Id ann $ parseRight 106 | where 107 | ann = (pos, dir, pattern) 108 | relPos' = relPos pos dir 109 | relPixel r = let (Pos px py) = relPos' r in pixel px py img 110 | 111 | pattern = quattern 112 | (relPixel LeftPos) 113 | (relPixel CenterPos) 114 | (relPixel FrontPos) 115 | (relPixel RightPos) 116 | 117 | parseLeft = parse (relPos' LeftPos) (rotateLeft dir) img 118 | parseFront = parse (relPos' FrontPos) dir img 119 | parseRight = parse (relPos' RightPos) (rotateRight dir) img 120 | 121 | areaLeft = S.size $ contiguous (relPos' LeftPos) img 122 | areaFront = S.size $ contiguous (relPos' FrontPos) img 123 | areaRight = S.size $ contiguous (relPos' RightPos) img 124 | 125 | parseImage 126 | :: forall img. (Image img, Eq (Pixel img), Show (Pixel img)) 127 | => Maybe Pos -> img -> Expr Ann ParseError (Pixel img) 128 | parseImage (Just (Pos x y)) img = parse (Pos x y) R img 129 | parseImage Nothing img = case initialPosition img of 130 | Nothing -> Err (Pos 0 0, R, AAAA) EmptyImage 131 | Just pos -> parse pos R img 132 | 133 | contiguous :: (Image img, Eq (Pixel img)) => Pos -> img -> S.Set Pos 134 | contiguous pos0@(Pos x0 y0) img = go (S.singleton pos0) (S.singleton pos0) 135 | where 136 | pixel0 = pixel x0 y0 img 137 | go acc frontier 138 | | S.null frontier = acc 139 | | otherwise = 140 | let nbs = 141 | S.filter (\(Pos x y) -> pixel x y img == pixel0) $ 142 | (`S.difference` acc) $ 143 | S.filter (`inside` img) $ 144 | S.fromList . concatMap neighbors $ S.toList frontier in 145 | go (S.union acc nbs) (S.difference nbs acc) 146 | -------------------------------------------------------------------------------- /hs/lib/Turnstyle/Prim.hs: -------------------------------------------------------------------------------- 1 | module Turnstyle.Prim 2 | ( Prim (..) 3 | , InMode (..) 4 | , OutMode (..) 5 | , NumOpMode (..) 6 | , CmpMode (..) 7 | , InexactMode (..) 8 | 9 | , knownPrims 10 | , primArity 11 | , primName 12 | , decodePrim 13 | , encodePrim 14 | ) where 15 | 16 | import qualified Data.Map as M 17 | 18 | data Prim 19 | = PIn InMode 20 | | POut OutMode 21 | | PNumOp NumOpMode 22 | | PCompare CmpMode 23 | | PInexact InexactMode 24 | deriving (Eq, Show) 25 | 26 | data InMode 27 | = InNumber 28 | | InChar 29 | deriving (Bounded, Enum, Eq, Show) 30 | 31 | data OutMode 32 | = OutNumber 33 | | OutChar 34 | deriving (Bounded, Enum, Eq, Show) 35 | 36 | data NumOpMode 37 | = NumOpAdd 38 | | NumOpSubtract 39 | | NumOpMultiply 40 | | NumOpDivide 41 | | NumOpModulo 42 | deriving (Bounded, Enum, Eq, Show) 43 | 44 | data CmpMode 45 | = CmpEq 46 | | CmpLessThan 47 | | CmpGreaterThan 48 | | CmpLessThanOrEqual 49 | | CmpGreaterThanOrEqual 50 | deriving (Bounded, Enum, Eq, Show) 51 | 52 | data InexactMode 53 | = InexactSqrt 54 | deriving (Bounded, Enum, Eq, Show) 55 | 56 | knownPrims :: [Prim] 57 | knownPrims = 58 | map PIn [minBound .. maxBound] <> 59 | map POut [minBound .. maxBound] <> 60 | map PNumOp [minBound .. maxBound] <> 61 | map PCompare [minBound .. maxBound] <> 62 | map PInexact [minBound .. maxBound] 63 | 64 | primArity :: Prim -> Int 65 | primArity (PIn _) = 2 66 | primArity (POut _) = 2 67 | primArity (PNumOp _) = 2 68 | primArity (PCompare _) = 4 69 | primArity (PInexact InexactSqrt) = 1 70 | 71 | primName :: Prim -> String 72 | primName (PIn InNumber) = "in_num" 73 | primName (PIn InChar) = "in_char" 74 | primName (POut OutNumber) = "out_num" 75 | primName (POut OutChar) = "out_char" 76 | primName (PNumOp NumOpAdd) = "num_add" 77 | primName (PNumOp NumOpSubtract) = "num_sub" 78 | primName (PNumOp NumOpMultiply) = "num_mul" 79 | primName (PNumOp NumOpDivide) = "num_div" 80 | primName (PNumOp NumOpModulo) = "num_mod" 81 | primName (PCompare CmpEq) = "cmp_eq" 82 | primName (PCompare CmpLessThan) = "cmp_lt" 83 | primName (PCompare CmpGreaterThan) = "cmp_gt" 84 | primName (PCompare CmpLessThanOrEqual) = "cmp_lte" 85 | primName (PCompare CmpGreaterThanOrEqual) = "cmp_gte" 86 | primName (PInexact InexactSqrt) = "inexact_sqrt" 87 | 88 | encodePrim :: Prim -> (Int, Int) 89 | encodePrim (PIn InNumber) = (1, 1) 90 | encodePrim (PIn InChar) = (1, 2) 91 | encodePrim (POut OutNumber) = (2, 1) 92 | encodePrim (POut OutChar) = (2, 2) 93 | encodePrim (PNumOp NumOpAdd) = (3, 1) 94 | encodePrim (PNumOp NumOpSubtract) = (3, 2) 95 | encodePrim (PNumOp NumOpMultiply) = (3, 3) 96 | encodePrim (PNumOp NumOpDivide) = (3, 4) 97 | encodePrim (PNumOp NumOpModulo) = (3, 5) 98 | encodePrim (PCompare CmpEq) = (4, 1) 99 | encodePrim (PCompare CmpLessThan) = (4, 2) 100 | encodePrim (PCompare CmpGreaterThan) = (4, 3) 101 | encodePrim (PCompare CmpLessThanOrEqual) = (4, 4) 102 | encodePrim (PCompare CmpGreaterThanOrEqual) = (4, 5) 103 | encodePrim (PInexact InexactSqrt) = (5, 1) 104 | 105 | decodeMap :: M.Map (Int, Int) Prim 106 | decodeMap = M.fromList [(encodePrim p, p) | p <- knownPrims] 107 | 108 | decodePrim :: Int -> Int -> Maybe Prim 109 | decodePrim modul opcode = M.lookup (modul, opcode) decodeMap 110 | -------------------------------------------------------------------------------- /hs/lib/Turnstyle/Quattern.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiWayIf #-} 2 | module Turnstyle.Quattern 3 | ( Quattern (..) 4 | , quattern 5 | ) where 6 | 7 | -- | A Quattern is a quad-pattern, a pattern consisting of four elements 8 | -- arranged in TurnStyle order. 9 | data Quattern 10 | = AAAA 11 | | AAAB 12 | | AABA 13 | | AABB 14 | | AABC 15 | | ABAA 16 | | ABAB 17 | | ABAC 18 | | ABBA 19 | | ABBB 20 | | ABBC 21 | | ABCA 22 | | ABCB 23 | | ABCC 24 | | ABCD 25 | deriving (Bounded, Enum, Eq, Ord, Show) 26 | 27 | quattern :: Eq a => a -> a -> a -> a -> Quattern 28 | quattern a x y z = if 29 | | x == a -> if | y == a -> if | z == a -> AAAA 30 | | otherwise -> AAAB 31 | | otherwise -> if | z == a -> AABA 32 | | z == y -> AABB 33 | | otherwise -> AABC 34 | | otherwise -> if | y == a -> if | z == a -> ABAA 35 | | z == x -> ABAB 36 | | otherwise -> ABAC 37 | | y == x -> if | z == a -> ABBA 38 | | z == x -> ABBB 39 | | otherwise -> ABBC 40 | | otherwise -> if | z == a -> ABCA 41 | | z == x -> ABCB 42 | | z == y -> ABCC 43 | | otherwise -> ABCD 44 | -------------------------------------------------------------------------------- /hs/lib/Turnstyle/Scale.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE TypeFamilies #-} 3 | module Turnstyle.Scale 4 | ( Scale (..) 5 | , Scaled (..) 6 | , autoScale 7 | ) where 8 | 9 | import Data.List.NonEmpty (NonEmpty ((:|)), group1) 10 | import Data.Semigroup (sconcat) 11 | import Turnstyle.Image 12 | 13 | data Scale = Scale Int Int deriving (Show) 14 | 15 | data Scaled img = Scaled Scale img 16 | 17 | instance Image img => Image (Scaled img) where 18 | type Pixel (Scaled img) = Pixel img 19 | width (Scaled (Scale xs _) img) = width img `div` xs 20 | height (Scaled (Scale _ ys) img) = height img `div` ys 21 | pixel x y (Scaled (Scale xs ys) img) = pixel (x * xs) (y * ys) img 22 | 23 | newtype Gcd = Gcd {unGcd :: Int} deriving (Show) 24 | 25 | instance Semigroup Gcd where 26 | Gcd x <> Gcd y = Gcd (gcd x y) 27 | 28 | findScale :: (Image img, Eq (Pixel img)) => img -> Scale 29 | findScale img = Scale (unGcd xScale) (unGcd yScale) 30 | where 31 | xScale :: Gcd 32 | xScale = sconcat $ fmap (Gcd . length) $ do 33 | y <- 0 :| [1 .. height img - 1] 34 | group1 $ do 35 | x <- 0 :| [1 .. width img - 1] 36 | pure $ pixel x y img 37 | 38 | yScale :: Gcd 39 | yScale = sconcat $ fmap (Gcd . length) $ do 40 | x <- 0 :| [1 .. width img - 1] 41 | group1 $ do 42 | y <- 0 :| [1 .. height img - 1] 43 | pure $ pixel x y img 44 | 45 | autoScale :: (Image img, Eq (Pixel img)) => img -> (Scaled img) 46 | autoScale img = Scaled (findScale img) img 47 | -------------------------------------------------------------------------------- /hs/lib/Turnstyle/Text.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | module Turnstyle.Text 4 | ( prettyExpr 5 | 6 | , Sugar 7 | , sugarImports 8 | , sugarToExpr 9 | , exprToSugar 10 | , parseSugar 11 | , prettySugar 12 | ) where 13 | 14 | import Turnstyle.Expr (Expr, normalizeVars) 15 | import Turnstyle.Text.Parse 16 | import Turnstyle.Text.Pretty 17 | import Turnstyle.Text.Sugar 18 | 19 | stringify :: forall ann e v. Ord v => Expr ann e v -> Expr ann e String 20 | stringify expr = (map pure ['a' ..] !!) <$> normalizeVars expr 21 | 22 | prettyExpr :: forall ann err v. (Show err, Ord v) => Expr ann err v -> String 23 | prettyExpr = prettySugar . exprToSugar . stringify 24 | -------------------------------------------------------------------------------- /hs/lib/Turnstyle/Text/Parse.hs: -------------------------------------------------------------------------------- 1 | module Turnstyle.Text.Parse 2 | ( parseSugar 3 | ) where 4 | 5 | import Control.Applicative ((<|>)) 6 | import Control.Monad (void) 7 | import Data.Char (isAlpha, isLower) 8 | import Data.List.NonEmpty (NonEmpty (..)) 9 | import qualified Data.Map as M 10 | import Data.Void (Void) 11 | import qualified Text.Parsec as P 12 | import qualified Text.Parsec.String as P 13 | import Turnstyle.Prim 14 | import Turnstyle.Text.Sugar 15 | 16 | parseSugar 17 | :: P.SourceName -> String -> Either P.ParseError (Sugar Void P.SourcePos) 18 | parseSugar name input = P.parse (spaceOrComments *> expr <* P.eof) name input 19 | 20 | expr :: P.Parser (Sugar Void P.SourcePos) 21 | expr = P.choice 22 | [ do 23 | pos <- P.getPosition 24 | keyword "LET" 25 | v <- var 26 | equal 27 | def <- expr 28 | keyword "IN" 29 | body <- expr 30 | pure $ Let pos v def body 31 | , do 32 | pos <- P.getPosition 33 | keyword "IMPORT" 34 | attrs <- attributes 35 | Import pos attrs <$> string 36 | , do 37 | pos <- P.getPosition 38 | e : es <- P.many1 expr1 39 | pure $ case es of 40 | [] -> e 41 | (x : xs) -> App pos e (x :| xs) 42 | ] 43 | 44 | expr1 :: P.Parser (Sugar Void P.SourcePos) 45 | expr1 = P.choice 46 | [ (P. "lambda") $ do 47 | pos <- P.getPosition 48 | lambda 49 | v : vs <- P.many1 var 50 | dot 51 | body <- expr 52 | pure $ Lam pos (v :| vs) body 53 | , do 54 | pos <- P.getPosition 55 | ident <- identifier 56 | case ident of 57 | VarId v -> pure $ Var pos v 58 | PrimId p -> pure $ Prim pos p 59 | , Lit <$> P.getPosition <*> lit 60 | , parens expr 61 | ] 62 | 63 | lambda :: P.Parser () 64 | lambda = void $ token $ P.char '\\' <|> P.char 'λ' 65 | 66 | dot :: P.Parser () 67 | dot = void $ token $ P.char '.' 68 | 69 | equal :: P.Parser () 70 | equal = void $ token $ P.char '=' 71 | 72 | keyword :: String -> P.Parser () 73 | keyword k = void $ token $ P.try $ P.string k 74 | 75 | parens :: P.Parser p -> P.Parser p 76 | parens p = token (P.char '(') *> p <* token (P.char ')') 77 | 78 | data Identifier = VarId String | PrimId Prim 79 | 80 | identifier :: P.Parser Identifier 81 | identifier = do 82 | str <- token $ (:) <$> identifierStart <*> P.many identifierChar 83 | case M.lookup str primsByName of 84 | Just p -> pure $ PrimId p 85 | Nothing -> pure $ VarId str 86 | 87 | var :: P.Parser String 88 | var = (P. "variable") $ do 89 | ident <- identifier 90 | case ident of 91 | VarId v -> pure v 92 | PrimId p -> fail $ "reserved name: " ++ primName p 93 | 94 | lit :: P.Parser Integer 95 | lit = token $ do 96 | decimal <- P.many1 P.digit 97 | case read decimal of 98 | 0 -> P.unexpected "zero literal" 99 | n -> pure n 100 | 101 | attributes :: P.Parser Attributes 102 | attributes = P.many attribute 103 | where 104 | attribute = do 105 | void $ P.char '@' 106 | key <- (:) <$> identifierStart <*> P.many identifierChar 107 | void $ P.char '=' 108 | val <- string 109 | pure (key, val) 110 | 111 | token :: P.Parser a -> P.Parser a 112 | token p = p <* spaceOrComments 113 | 114 | identifierStart :: P.Parser Char 115 | identifierStart = P.satisfy (\c -> isAlpha c && isLower c && c /= 'λ') 116 | 117 | identifierChar :: P.Parser Char 118 | identifierChar = identifierStart <|> P.digit <|> P.char '_' 119 | 120 | spaceOrComments :: P.Parser () 121 | spaceOrComments = P.skipMany (comment <|> P.space P. "") 122 | where 123 | comment = P.char '#' <* P.manyTill P.anyChar (void P.newline <|> P.eof) 124 | 125 | string :: P.Parser String 126 | string = token $ do 127 | void $ P.char '"' 128 | str <- P.manyTill stringChar (P.char '"') 129 | pure str 130 | where 131 | stringChar = (P.char '\\' >> P.anyChar) <|> P.satisfy (/= '"') 132 | 133 | primsByName :: M.Map String Prim 134 | primsByName = M.fromList [(primName p, p) | p <- knownPrims] 135 | -------------------------------------------------------------------------------- /hs/lib/Turnstyle/Text/Pretty.hs: -------------------------------------------------------------------------------- 1 | module Turnstyle.Text.Pretty 2 | ( prettySugar 3 | , prettyAttributes 4 | ) where 5 | 6 | import Data.Foldable (toList) 7 | import Turnstyle.Prim 8 | import Turnstyle.Text.Sugar 9 | 10 | prettySugar :: Show err => Sugar err ann -> String 11 | prettySugar = go 12 | where 13 | go expr = case expr of 14 | Let _ v d b -> "LET " ++ v ++ " = " ++ go d ++ " IN\n" ++ go b 15 | Import _ [] s -> "IMPORT " ++ show s 16 | Import _ as s -> "IMPORT " ++ prettyAttributes as ++ " " ++ show s 17 | App _ f xs -> unwords $ parens f : map parens (toList xs) 18 | Lam _ vs e -> "λ" ++ unwords (toList vs) ++ ". " ++ go e 19 | Var _ v -> v 20 | Prim _ p -> primName p 21 | Lit _ l -> show l 22 | Err _ e -> "<" ++ show e ++ ">" 23 | 24 | 25 | parens expr = case expr of 26 | Lam _ _ _ -> "(" ++ go expr ++ ")" 27 | App _ _ _ -> "(" ++ go expr ++ ")" 28 | _ -> go expr 29 | 30 | prettyAttributes :: Attributes -> String 31 | prettyAttributes attrs = unwords ["@" ++ k ++ "=" ++ show v | (k, v) <- attrs] 32 | -------------------------------------------------------------------------------- /hs/lib/Turnstyle/Text/Sugar.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFunctor #-} 2 | module Turnstyle.Text.Sugar 3 | ( Attributes 4 | , Sugar (..) 5 | , sugarImports 6 | , sugarToExpr 7 | , exprToSugar 8 | ) where 9 | 10 | import Data.List.NonEmpty (NonEmpty (..)) 11 | import qualified Data.Set as S 12 | import qualified Turnstyle.Expr as E 13 | import Turnstyle.Prim (Prim) 14 | 15 | type Attributes = [(String, String)] 16 | 17 | data Sugar err ann 18 | = Let ann String (Sugar err ann) (Sugar err ann) 19 | | Import ann Attributes FilePath 20 | | App ann (Sugar err ann) (NonEmpty (Sugar err ann)) 21 | | Lam ann (NonEmpty String) (Sugar err ann) 22 | | Var ann String 23 | | Prim ann Prim 24 | | Lit ann Integer 25 | | Err ann err 26 | deriving (Eq, Functor, Show) 27 | 28 | sugarImports :: Sugar err ann -> S.Set FilePath 29 | sugarImports (Let _ _ d b) = sugarImports d <> sugarImports b 30 | sugarImports (Import _ _ p) = S.singleton p 31 | sugarImports (App _ f xs) = sugarImports f <> foldMap sugarImports xs 32 | sugarImports (Lam _ _ b) = sugarImports b 33 | sugarImports (Var _ _) = S.empty 34 | sugarImports (Prim _ _) = S.empty 35 | sugarImports (Lit _ _) = S.empty 36 | sugarImports (Err _ _) = S.empty 37 | 38 | sugarToExpr 39 | :: (ann -> FilePath -> E.Expr ann err String) 40 | -> Sugar err ann -> E.Expr ann err String 41 | sugarToExpr imports (Let ann v d b) = 42 | E.App ann (E.Lam ann v (sugarToExpr imports b)) (sugarToExpr imports d) 43 | sugarToExpr imports (Import ann _ fp) = imports ann fp 44 | sugarToExpr imports (App ann f xs) = 45 | foldl (E.App ann) (sugarToExpr imports f) (fmap (sugarToExpr imports) xs) 46 | sugarToExpr imports (Lam ann vs b) 47 | = foldr (E.Lam ann) (sugarToExpr imports b) vs 48 | sugarToExpr _ (Var ann v) = E.Var ann v 49 | sugarToExpr _ (Prim ann p) = E.Prim ann p 50 | sugarToExpr _ (Lit ann l) = E.Lit ann l 51 | sugarToExpr _ (Err ann e) = E.Err ann e 52 | 53 | unApp 54 | :: E.Expr ann err v -> Maybe (E.Expr ann err v, NonEmpty (E.Expr ann err v)) 55 | unApp (E.App _ f0 x) = case unApp f0 of 56 | Nothing -> Just (f0, x :| []) 57 | Just (f1, xs) -> Just (f1, xs <> (x :| [])) 58 | unApp _ = Nothing 59 | 60 | unLam :: E.Expr ann err v -> Maybe (NonEmpty v, E.Expr ann err v) 61 | unLam (E.Lam _ v body0) = case unLam body0 of 62 | Nothing -> Just (v :| [], body0) 63 | Just (vs, body1) -> Just ((v :| []) <> vs, body1) 64 | unLam _ = Nothing 65 | 66 | exprToSugar :: E.Expr ann err String -> Sugar err ann 67 | exprToSugar expr = case expr of 68 | E.App ann _ _ | Just (f, xs) <- unApp expr -> App ann (exprToSugar f) (exprToSugar <$> xs) 69 | E.App ann f x -> App ann (exprToSugar f) (exprToSugar x :| []) 70 | E.Lam ann _ _ | Just (vs, b) <- unLam expr -> Lam ann vs (exprToSugar b) 71 | E.Lam ann v b -> Lam ann (v :| []) (exprToSugar b) 72 | E.Var ann v -> Var ann v 73 | E.Prim ann p -> Prim ann p 74 | E.Lit ann l -> Lit ann l 75 | E.Id _ e -> exprToSugar e 76 | E.Err ann e -> Err ann e 77 | -------------------------------------------------------------------------------- /hs/lib/Turnstyle/TwoD.hs: -------------------------------------------------------------------------------- 1 | module Turnstyle.TwoD 2 | ( Pos (..) 3 | , neighbors 4 | , Dir (..) 5 | , move 6 | , rotateLeft 7 | , rotateRight 8 | ) where 9 | 10 | data Pos = Pos {-# UNPACK #-} !Int {-# UNPACK #-} !Int deriving (Eq, Ord, Show) 11 | 12 | neighbors :: Pos -> [Pos] 13 | neighbors p = [move 1 d p | d <- [R, D, L, U]] 14 | 15 | data Dir = R | D | L | U deriving (Eq, Ord, Show) 16 | 17 | move :: Int -> Dir -> Pos -> Pos 18 | move n R (Pos x y) = Pos (x + n) (y ) 19 | move n D (Pos x y) = Pos (x ) (y + n) 20 | move n L (Pos x y) = Pos (x - n) (y ) 21 | move n U (Pos x y) = Pos (x ) (y - n) 22 | 23 | rotateLeft, rotateRight :: Dir -> Dir 24 | rotateLeft R = U 25 | rotateLeft D = R 26 | rotateLeft L = D 27 | rotateLeft U = L 28 | rotateRight = rotateLeft . rotateLeft . rotateLeft 29 | -------------------------------------------------------------------------------- /hs/src/AnnotateExamples.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | import qualified Codec.Picture as JP 3 | import qualified Data.ByteString.Lazy as BL 4 | import Data.Foldable (for_) 5 | import Data.List (isSuffixOf) 6 | import Numeric (showHex) 7 | import System.Directory (listDirectory) 8 | import System.FilePath (dropExtension, ()) 9 | import qualified System.IO as IO 10 | import Text.Blaze.Svg.Renderer.Utf8 (renderSvg) 11 | import qualified Text.Blaze.Svg11 as Svg 12 | import qualified Text.Blaze.Svg11.Attributes as A 13 | 14 | annotate :: Int -> JP.Image JP.PixelRGBA8 -> Svg.Svg 15 | annotate factor ref = Svg.docTypeSvg 16 | Svg.! A.version "1.1" 17 | Svg.! A.width (Svg.toValue width) 18 | Svg.! A.height (Svg.toValue height) $ do 19 | 20 | for_ [0 .. JP.imageHeight ref - 1] $ \y -> 21 | for_ [0 .. JP.imageWidth ref - 1] $ \x -> do 22 | case JP.pixelAt ref x y of 23 | JP.PixelRGBA8 _ _ _ 0 -> mempty :: Svg.Svg 24 | JP.PixelRGBA8 r g b _ -> Svg.rect 25 | Svg.! A.x (Svg.toValue (padding + x * factor)) 26 | Svg.! A.y (Svg.toValue (padding + y * factor)) 27 | Svg.! A.width (Svg.toValue factor) 28 | Svg.! A.height (Svg.toValue factor) 29 | Svg.! A.fill (Svg.toValue $ hexColor r g b) 30 | 31 | let cx = padding + factor `div` 2 32 | cy = padding + initialY * factor + factor `div` 2 33 | cr = factor `div` 6 34 | ox = padding 35 | oy = padding + initialY * factor 36 | tw = cr 37 | Svg.circle 38 | Svg.! A.cx (Svg.toValue cx) 39 | Svg.! A.cy (Svg.toValue cy) 40 | Svg.! A.r (Svg.toValue cr) 41 | Svg.! A.fill "#000" 42 | Svg.line 43 | Svg.! A.x1 (Svg.toValue cx) 44 | Svg.! A.y1 (Svg.toValue cy) 45 | Svg.! A.x2 (Svg.toValue (cx + factor)) 46 | Svg.! A.y2 (Svg.toValue cy) 47 | Svg.! A.stroke "#000" 48 | Svg.! A.strokeWidth "2" 49 | let triangle = 50 | [ (cx + factor - tw, cy - tw) 51 | , (cx + factor + tw, cy) 52 | , (cx + factor - tw, cy + tw) 53 | ] 54 | Svg.polygon 55 | Svg.! A.points (pointsValue triangle) 56 | Svg.! A.fill "#000" 57 | let outline = 58 | [ (ox, oy - factor) 59 | , (ox + factor, oy - factor) 60 | , (ox + factor, oy) 61 | , (ox + factor + factor, oy) 62 | , (ox + factor + factor, oy + factor) 63 | , (ox + factor, oy + factor) 64 | , (ox + factor, oy + factor + factor) 65 | , (ox, oy + factor + factor) 66 | , (ox, oy - factor) 67 | ] 68 | Svg.polyline 69 | Svg.! A.points (pointsValue outline) 70 | Svg.! A.stroke "#0008" 71 | Svg.! A.fill "none" 72 | Svg.! A.strokeWidth "1" 73 | where 74 | padding = factor `div` 10 75 | width = factor * JP.imageWidth ref + padding * 2 76 | height = factor * JP.imageHeight ref + padding * 2 77 | 78 | hexColor r g b = "#" ++ hexWord r ++ hexWord g ++ hexWord b 79 | hexWord w = case showHex w "" of 80 | [h] -> ['0', h] 81 | h -> h 82 | 83 | initialY = JP.imageHeight ref `div` 2 84 | 85 | pointsValue points = Svg.toValue $ unwords 86 | [show x ++ "," ++ show y | (x, y) <- points] 87 | 88 | main :: IO () 89 | main = do 90 | examples <- filter (not . (".svg" `isSuffixOf`)) <$> 91 | listDirectory "examples" 92 | for_ examples $ \example -> do 93 | let path = "examples" example 94 | IO.hPutStrLn IO.stderr $ "Annotating " ++ path ++ "..." 95 | img <- JP.readImage path >>= either fail pure 96 | let base = dropExtension example 97 | BL.writeFile ("examples" base ++ ".svg") $ renderSvg $ 98 | annotate 20 $ JP.convertRGBA8 img 99 | -------------------------------------------------------------------------------- /hs/src/Main.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | import qualified Turnstyle.Main 4 | 5 | main :: IO () 6 | main = Turnstyle.Main.main 7 | -------------------------------------------------------------------------------- /hs/src/Recolor.hs: -------------------------------------------------------------------------------- 1 | import qualified Codec.Picture as JP 2 | import Data.Either.Validation (Validation (..)) 3 | import qualified Data.Map as M 4 | import qualified Data.Set as S 5 | import Data.Word (Word8) 6 | import Numeric (readHex) 7 | import qualified Options.Applicative as OA 8 | import Turnstyle.Compile.Paint (paint) 9 | import Turnstyle.Compile.Recompile (recompile) 10 | import Turnstyle.Compile.Shape (Shape (..)) 11 | import Turnstyle.Compile.Solve (solve) 12 | import Turnstyle.Expr (checkErrors) 13 | import Turnstyle.Image 14 | import Turnstyle.JuicyPixels (loadImage) 15 | import Turnstyle.Parse 16 | 17 | data Color = Color Word8 Word8 Word8 deriving (Show) 18 | 19 | colorToPixel :: Color -> JP.PixelRGBA8 20 | colorToPixel (Color r g b) = JP.PixelRGBA8 r g b 255 21 | 22 | colorReader :: String -> Either String Color 23 | colorReader (r0 : r1 : g0 : g1 : b0 : b1 : []) = 24 | maybe (Left "could not parse color") Right $ 25 | Color <$> parseHex [r0, r1] <*> parseHex [g0, g1] <*> parseHex [b0, b1] 26 | where 27 | parseHex str = case readHex str of 28 | [(n, "")] -> Just n 29 | _ -> Nothing 30 | colorReader _ = Left "expected rrggbb" 31 | 32 | data Options = Options 33 | { oColors :: [Color] 34 | , oRecompile :: Bool 35 | , oFilePath :: FilePath 36 | } deriving (Show) 37 | 38 | parseOptions :: OA.Parser Options 39 | parseOptions = Options 40 | <$> OA.many (OA.option (OA.eitherReader colorReader) 41 | (OA.long "color" <> OA.short 'c' <> OA.metavar "rrggbb")) 42 | <*> OA.switch (OA.long "recompile") 43 | <*> OA.argument OA.str (OA.metavar "IMAGE.PNG") 44 | 45 | recolor 46 | :: [Color] -> JP.Image JP.PixelRGBA8 47 | -> Either String (JP.Image JP.PixelRGBA8) 48 | recolor colors ref 49 | | S.size refColors > length colors = Left $ 50 | "not enough colors (need " ++ show (S.size refColors) ++ ")" 51 | | otherwise = Right $ JP.generateImage 52 | (\x y -> 53 | let p = JP.pixelAt ref x y in 54 | maybe p colorToPixel (M.lookup p mapColors)) 55 | (JP.imageWidth ref) 56 | (JP.imageHeight ref) 57 | where 58 | mapColors = M.fromList $ zip (S.toList refColors) colors 59 | 60 | refColors = S.fromList $ do 61 | x <- [0 .. JP.imageWidth ref - 1] 62 | y <- [0 .. JP.imageHeight ref - 1] 63 | case JP.pixelAt ref x y of 64 | JP.PixelRGBA8 _ _ _ 0 -> [] 65 | p -> [p] 66 | 67 | main :: IO () 68 | main = do 69 | args <- OA.execParser opts 70 | result <- case oRecompile args of 71 | True -> do 72 | img <- loadImage $ oFilePath args 73 | expr <- case checkErrors (parseImage Nothing img) of 74 | Success e -> pure e 75 | Failure err -> fail $ show err 76 | let constrs = recompile img expr 77 | palette = map colorToPixel $ oColors args 78 | solution <- either (fail . show) pure $ solve palette constrs 79 | let shape = Shape 80 | { sWidth = width img 81 | , sHeight = height img 82 | , sEntrance = height img `div` 2 83 | , sConstraints = constrs 84 | } 85 | pure $ paint solution shape 86 | False -> do 87 | img <- JP.readImage (oFilePath args) >>= either fail pure 88 | either fail pure $ recolor (oColors args) (JP.convertRGBA8 img) 89 | JP.savePngImage (oFilePath args) $ JP.ImageRGBA8 $ result 90 | where 91 | opts = OA.info (parseOptions OA.<**> OA.helper) OA.fullDesc 92 | -------------------------------------------------------------------------------- /hs/src/SpecFigures.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE NoMonomorphismRestriction #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | {-# LANGUAGE TypeFamilies #-} 5 | import Diagrams.Backend.SVG 6 | import Diagrams.Prelude 7 | 8 | data Pixel = A | B | C | D deriving (Eq, Show) 9 | 10 | colorToStyle :: Pixel -> Colour Double 11 | colorToStyle A = sRGB24read "#eeb480" 12 | colorToStyle B = sRGB24read "#b5decc" 13 | colorToStyle C = sRGB24read "#ffdd00" 14 | colorToStyle D = sRGB24read "#b2b73e" 15 | 16 | data Arrow 17 | = NoArrow 18 | | Arrow 19 | | DashedArrow 20 | deriving (Eq, Show) 21 | 22 | data Turnstyle = Turnstyle 23 | { frameSize :: Double 24 | , leftPixel :: Pixel 25 | , leftArrow :: Arrow 26 | , leftLabel :: Maybe String 27 | , leftCircle :: Bool 28 | , centerPixel :: Pixel 29 | , centerArrow :: Arrow 30 | , centerLabel :: Maybe String 31 | , centerCircle :: Bool 32 | , frontPixel :: Pixel 33 | , frontArrow :: Arrow 34 | , frontLabel :: Maybe String 35 | , frontCircle :: Bool 36 | , rightPixel :: Pixel 37 | , rightArrow :: Arrow 38 | , rightLabel :: Maybe String 39 | , rightCircle :: Bool 40 | } 41 | 42 | mkTurnstyle :: Pixel -> Pixel -> Pixel -> Pixel -> Turnstyle 43 | mkTurnstyle u c r d = Turnstyle 44 | { frameSize = 1 45 | , leftPixel = u 46 | , leftArrow = NoArrow 47 | , leftLabel = Nothing 48 | , leftCircle = False 49 | , centerPixel = c 50 | , centerArrow = NoArrow 51 | , centerLabel = Nothing 52 | , centerCircle = False 53 | , frontPixel = r 54 | , frontArrow = NoArrow 55 | , frontLabel = Nothing 56 | , frontCircle = False 57 | , rightPixel = d 58 | , rightArrow = NoArrow 59 | , rightLabel = Nothing 60 | , rightCircle = False 61 | } 62 | 63 | turnstyle :: Turnstyle -> Diagram B 64 | turnstyle Turnstyle {..} = 65 | atop (moveTo (0.5 ^& (0.0)) $ rotateBy (0/4) $ mkArrow leftArrow) $ 66 | atop (moveTo (0.5 ^& (-1.0)) $ rotateBy (3/4) $ mkArrow centerArrow) $ 67 | atop (moveTo (1.5 ^& (-1.0)) $ rotateBy (3/4) $ mkArrow frontArrow) $ 68 | atop (moveTo (0.5 ^& (-2.0)) $ rotateBy (2/4) $ mkArrow rightArrow) $ 69 | frame frameSize $ 70 | lw none $ 71 | alignL (tile leftLabel leftCircle leftPixel) 72 | === 73 | alignL (tile centerLabel centerCircle centerPixel ||| 74 | tile frontLabel frontCircle frontPixel) 75 | === 76 | alignL (tile rightLabel rightCircle rightPixel) 77 | where 78 | mkArrow NoArrow = mempty 79 | mkArrow Arrow = 80 | fromVertices [P zero, P unitY] <> 81 | (moveTo (P unitY) $ fc black $ triangle 0.2) 82 | mkArrow DashedArrow = 83 | dashingL [0.1, 0.1] 0 fromVertices [P zero, P unitY] <> 84 | (moveTo (P unitY) $ fc black $ triangle 0.2) 85 | 86 | tile label circ color = 87 | (case label of 88 | Nothing -> mempty 89 | Just txt -> translateY (-1/8) $ scale (2/3) (text txt)) `atop` 90 | (if circ then lw none $ fc black $ circle 0.1 else mempty) `atop` 91 | fc (colorToStyle color) (square 1) 92 | 93 | appSpec :: Diagram B 94 | appSpec = 95 | turnstyle (mkTurnstyle A B A C) {leftArrow = Arrow, leftCircle = True, frontArrow = DashedArrow, frontCircle = True} ||| 96 | turnstyle (mkTurnstyle A B C A) {leftArrow = Arrow, leftCircle = True, rightArrow = DashedArrow, rightCircle = True} ||| 97 | turnstyle (mkTurnstyle B C A A) {frontArrow = Arrow, frontCircle = True, rightArrow = DashedArrow, rightCircle = True} 98 | lamSpec :: Diagram B 99 | lamSpec = 100 | turnstyle (mkTurnstyle C A B A) {rightArrow = Arrow, rightCircle = True, leftLabel = Just "L"} ||| 101 | turnstyle (mkTurnstyle B A A C) {frontArrow = Arrow, frontCircle = True, centerLabel = Just "C"} ||| 102 | turnstyle (mkTurnstyle A A B C) {leftArrow = Arrow, leftCircle = True, rightLabel = Just "R"} 103 | varSpec :: Diagram B 104 | varSpec = 105 | turnstyle (mkTurnstyle A B B B) {leftLabel = Just "L"} ||| 106 | turnstyle (mkTurnstyle B A B B) {centerLabel = Just "C"} ||| 107 | turnstyle (mkTurnstyle B B A B) {frontLabel = Just "F"} ||| 108 | turnstyle (mkTurnstyle B B B A) {rightLabel = Just "R"} 109 | symbolSpec :: Diagram B 110 | symbolSpec = 111 | turnstyle (mkTurnstyle A B C D) 112 | {leftLabel = Just "L", frontLabel = Just "F", rightLabel = Just "R"} 113 | idSpec :: Diagram B 114 | idSpec = 115 | turnstyle (mkTurnstyle A A A A) {frontArrow = Arrow, frontCircle = True} ||| 116 | turnstyle (mkTurnstyle B A A B) {frontArrow = Arrow, frontCircle = True} ||| 117 | turnstyle (mkTurnstyle A A B B) {leftArrow = Arrow, leftCircle = True} ||| 118 | turnstyle (mkTurnstyle B A B A) {rightArrow = Arrow, rightCircle = True} 119 | 120 | main :: IO () 121 | main = do 122 | renderSVG "spec/enter.svg" (mkHeight 400) $ 123 | let enter = turnstyle (mkTurnstyle A B C D) 124 | {centerArrow = Arrow, centerCircle = True} in 125 | alignT enter ||| 126 | translateY (-1) (alignT (rotateBy (3 / 4) enter)) ||| 127 | alignT (rotateBy (2 / 4) enter) ||| 128 | alignT (rotateBy (1 / 4) enter) 129 | renderSVG "spec/label.svg" (mkHeight 400) $ 130 | turnstyle (mkTurnstyle A B C D) {centerArrow = Arrow, centerCircle = True} ||| 131 | turnstyle (mkTurnstyle A B C D) 132 | {leftLabel = Just "L", centerLabel = Just "C", frontLabel = Just "F", rightLabel = Just "R"} 133 | renderSVG "spec/app.svg" (mkHeight 400) appSpec 134 | renderSVG "spec/lam.svg" (mkHeight 400) lamSpec 135 | renderSVG "spec/var.svg" (mkHeight 400) varSpec 136 | renderSVG "spec/symbol.svg" (mkHeight 400) symbolSpec 137 | renderSVG "spec/id.svg" (mkHeight 400) idSpec 138 | 139 | renderSVG "spec/cheatsheet.svg" (mkHeight 1600) $ 140 | ((moveTo (0 ^& (-1)) $ frame 2 $ italic $ text "x") <> 141 | (moveTo (0 ^& (-6)) $ frame 2 $ italic $ text "(λv.e)") <> 142 | (moveTo (0 ^& (-11)) $ frame 2 $ italic $ text "(f x)") <> 143 | (moveTo (0 ^& (-16)) $ frame 2 $ font "monospace" $ text "sym") <> 144 | (moveTo (0 ^& (-21)) $ frame 2 $ italic $ text "I")) ||| 145 | (varSpec === 146 | lamSpec === 147 | appSpec === 148 | (atop symbolSpec $ 149 | (moveTo (3.7 ^& (-0.4)) $ italic $ scale (3/4) $ 150 | alignedText 0 0.5 "a(L)=1 ⇒ Num(a(F)^a(R))") <> 151 | (moveTo (3.7 ^& (-1.6)) $ italic $ scale (3/4) $ 152 | alignedText 0 0.5 "a(L)=2 ⇒ Prim(a(F), a(R))")) === 153 | idSpec) 154 | 155 | renderSVG "website/turnstyle.svg" (mkHeight 400) $ 156 | turnstyle (mkTurnstyle A B C D) {frameSize = 0} 157 | -------------------------------------------------------------------------------- /hs/src/Website.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE RecordWildCards #-} 3 | module Main (main) where 4 | 5 | import Control.Applicative (empty) 6 | import Data.Foldable (for_) 7 | import Hakyll 8 | import qualified System.Process as Process 9 | import qualified Text.Pandoc as Pandoc 10 | 11 | data Page = Page 12 | { pageSrc :: Pattern 13 | , pageDst :: String 14 | , pageTitle :: Maybe String 15 | , pageNumberSections :: Bool 16 | } 17 | 18 | pages :: [Page] 19 | pages = 20 | [ Page "website/home.md" "index.html" (Just "Turnstyle") False 21 | , Page "spec/README.md" "spec/index.html" Nothing True 22 | , Page "website/playground.html" "playground/index.html" (Just "Turnstyle Playground") False 23 | ] 24 | 25 | main :: IO () 26 | main = hakyllWith config $ do 27 | match "spec/*.svg" $ do 28 | route idRoute 29 | compile copyFileCompiler 30 | match "turnstyle.js" $ do 31 | route idRoute 32 | compile copyFileCompiler 33 | match ("examples/*.png" .||. "examples/*.svg") $ do 34 | route idRoute 35 | compile copyFileCompiler 36 | match "website/turnstyle.svg" $ do 37 | route $ constRoute "turnstyle.svg" 38 | compile copyFileCompiler 39 | match "website/preview.png" $ do 40 | route $ constRoute "preview.png" 41 | compile copyFileCompiler 42 | match "website/favicon.ico" $ do 43 | route $ constRoute "favicon.ico" 44 | compile copyFileCompiler 45 | for_ pages $ \Page {..} -> match pageSrc $ do 46 | let ctx = maybe mempty (constField "title") pageTitle <> 47 | functionField "active" (\args _ -> do 48 | if args == [pageDst] then pure "true" else empty) <> 49 | defaultContext 50 | readerOpts = defaultHakyllReaderOptions 51 | writerOpts = defaultHakyllWriterOptions 52 | { Pandoc.writerNumberSections = pageNumberSections 53 | } 54 | route $ constRoute pageDst 55 | compile $ pandocCompilerWith readerOpts writerOpts >>= 56 | loadAndApplyTemplate "website/template.html" ctx >>= 57 | relativizeUrls 58 | match "website/style.css" $ do 59 | route $ constRoute "style.css" 60 | compile compressCssCompiler 61 | match "website/template.html" $ compile templateCompiler 62 | 63 | config :: Configuration 64 | config = defaultConfiguration 65 | { deploySite = \_ -> Process.rawSystem "rsync" 66 | [ "--checksum", "-ave", "ssh -p 2222" 67 | , "_site/", "jaspervdj@jaspervdj.be:jaspervdj.be/turnstyle/" 68 | ] 69 | } 70 | -------------------------------------------------------------------------------- /hs/test/Main.hs: -------------------------------------------------------------------------------- 1 | import Test.Tasty (defaultMain, testGroup) 2 | import qualified Turnstyle.Compile.Tests 3 | import qualified Turnstyle.Eval.Tests 4 | import qualified Turnstyle.Parse.Tests 5 | import qualified Turnstyle.Quattern.Tests 6 | import qualified Turnstyle.Text.Tests 7 | 8 | main :: IO () 9 | main = defaultMain $ testGroup "Turnstyle" 10 | [ Turnstyle.Compile.Tests.tests 11 | , Turnstyle.Eval.Tests.tests 12 | , Turnstyle.Parse.Tests.tests 13 | , Turnstyle.Quattern.Tests.tests 14 | , Turnstyle.Text.Tests.tests 15 | ] 16 | -------------------------------------------------------------------------------- /hs/test/Turnstyle/Compile/Tests.hs: -------------------------------------------------------------------------------- 1 | module Turnstyle.Compile.Tests 2 | ( tests 3 | ) where 4 | 5 | import qualified Codec.Picture as JP 6 | import Data.Either.Validation (Validation (..)) 7 | import qualified Data.Map as M 8 | import qualified Data.Set as S 9 | import Test.Tasty (TestTree, testGroup) 10 | import Test.Tasty.HUnit (assertBool, testCase, (@?=)) 11 | import qualified Test.Tasty.QuickCheck as QC 12 | import Turnstyle.Compile 13 | import Turnstyle.Compile.Paint (defaultPalette) 14 | import qualified Turnstyle.Eval as E 15 | import Turnstyle.Eval (eval) 16 | import Turnstyle.Eval.Tests (EvalState (..), emptyEvalState, 17 | runEvalPure) 18 | import Turnstyle.Expr 19 | import Turnstyle.Expr.Tests 20 | import Turnstyle.Image 21 | import Turnstyle.JuicyPixels 22 | import Turnstyle.Parse 23 | import Turnstyle.Text (exprToSugar, parseSugar) 24 | import Turnstyle.Text.Pretty (prettyAttributes) 25 | import Turnstyle.Text.Sugar (Attributes) 26 | 27 | tests :: TestTree 28 | tests = testGroup "Turnstyle.Compile" 29 | [ QC.testProperty "parse . compile" $ \(GenExpr expr) -> 30 | let sugar = exprToSugar (show <$> expr) in 31 | case compile defaultCompileOptions sugar of 32 | Left err -> error $ "compile error: " ++ show err 33 | Right img -> case checkErrors (parseImage Nothing (JuicyPixels img)) of 34 | Failure err -> error $ "parse error: " ++ show err 35 | Success parsed -> toDeBruijn expr == toDeBruijn parsed 36 | , QC.testProperty "parse . compile (opt)" $ \(GenExpr expr) -> 37 | let sugar = exprToSugar (show <$> expr) in 38 | case compile defaultCompileOptions {coOptimize = True, coBudget = 10} sugar of 39 | Left err -> error $ "compile error: " ++ show err 40 | Right img -> case checkErrors (parseImage Nothing (JuicyPixels img)) of 41 | Failure err -> error $ "parse error: " ++ show err 42 | Success parsed -> toDeBruijn expr == toDeBruijn parsed 43 | , rot13 "rot13" [] 44 | , rot13 "rot13 (recompile)" [("recompile", "true")] 45 | , testGroup "defaultPalette" $ 46 | [ testCase "length" $ 47 | let len = length defaultPalette in 48 | assertBool ("insufficient: " ++ show len) (len >= 64) 49 | , testCase "quality" $ assertBool "colors are not unique" $ 50 | length defaultPalette == S.size (S.fromList defaultPalette) 51 | ] 52 | ] 53 | where 54 | 55 | rot13 :: String -> Attributes -> TestTree 56 | rot13 name importAttrs = testCase name $ do 57 | sugar <- either (fail . show) pure $ parseSugar "rot13.txt" src 58 | img <- either (fail . show) pure $ compile 59 | defaultCompileOptions {coImports = M.singleton "y.png" yImage} 60 | sugar 61 | let expr = parseImage Nothing (JuicyPixels img) 62 | (result, finalState) = runEvalPure (eval expr) 63 | emptyEvalState {esInChars = "abc\ndef\n"} 64 | result @?= Right (E.Lit 0) 65 | esOutChars finalState @?= reverse "nop\nqrs\n" 66 | where 67 | src = unlines 68 | [ "LET y = IMPORT " ++ prettyAttributes importAttrs ++ " \"y.png\" IN" 69 | , "LET char_a = num_add (num_mul 10 9) 7 IN" 70 | , "LET char_z = num_add char_a 25 IN" 71 | , "LET and = λp q. p q p IN" 72 | , "LET alpha = λn. and (cmp_gt n (num_sub char_a 1))" 73 | , " (cmp_lt n (num_add 1 char_z)) IN" 74 | , "LET rot13 = λn. (alpha n)" 75 | , " (num_add char_a (num_mod (num_add 13 (num_sub n char_a)) 26))" 76 | , " n IN" 77 | , "y (λrec. in_char (λn. out_char (rot13 n) rec) (num_sub 1 1))" 78 | ] 79 | 80 | yImage :: JuicyPixels 81 | yImage = mkJuicyPixels 82 | [ [a, a, a, a, y, a, a] 83 | , [a, a, g, y, b, y, a] 84 | , [a, r, g, b, g, b, y] 85 | , [y, y, g, b, r, y, a] 86 | , [r, r, r, r, y, a, a] 87 | , [y, y, a, b, g, a, a] 88 | , [y, b, g, b, g, r, a] 89 | , [a, y, b, y, g, a, a] 90 | , [a, a, y, a, a, a, a] 91 | ] 92 | where 93 | a = JP.PixelRGBA8 0 0 0 0 94 | y = JP.PixelRGBA8 255 0 0 255 95 | g = JP.PixelRGBA8 255 255 0 255 96 | b = JP.PixelRGBA8 0 255 255 255 97 | r = JP.PixelRGBA8 0 0 255 255 98 | 99 | mkJuicyPixels :: [[Pixel JuicyPixels]] -> JuicyPixels 100 | mkJuicyPixels pixels = JuicyPixels $ JP.generateImage 101 | (\x y -> pixels !! y !! x) (length (head pixels)) (length pixels) 102 | -------------------------------------------------------------------------------- /hs/test/Turnstyle/Eval/Tests.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | module Turnstyle.Eval.Tests 3 | ( EvalState (..) 4 | , emptyEvalState 5 | , EvalPure 6 | , runEvalPure 7 | 8 | , tests 9 | ) where 10 | 11 | import Control.Monad.Except (ExceptT, runExceptT, throwError) 12 | import Control.Monad.State (State, modify, runState, state) 13 | import Test.Tasty (TestTree, testGroup) 14 | import Test.Tasty.HUnit (testCase, (@?=)) 15 | import Turnstyle.Eval 16 | import Turnstyle.JuicyPixels (loadImage) 17 | import Turnstyle.Number 18 | import Turnstyle.Parse (parseImage) 19 | import Turnstyle.Scale (autoScale) 20 | 21 | data EvalState = EvalState 22 | { esInNumbers :: [Integer] 23 | , esInChars :: [Char] 24 | , esOutNumbers :: [Number] 25 | , esOutChars :: [Char] 26 | } 27 | 28 | emptyEvalState :: EvalState 29 | emptyEvalState = EvalState [] [] [] [] 30 | 31 | newtype EvalPure a = 32 | EvalPure {unEvalPure :: ExceptT EvalException (State EvalState) a} 33 | deriving (Applicative, Functor, Monad) 34 | 35 | instance MonadEval EvalPure where 36 | evalThrow = EvalPure . throwError 37 | evalInputNumber = EvalPure $ state $ \es -> case esInNumbers es of 38 | [] -> (Nothing, es) 39 | x : xs -> (Just x, es {esInNumbers = xs}) 40 | evalInputChar = EvalPure $ state $ \es -> case esInChars es of 41 | [] -> (Nothing, es) 42 | x : xs -> (Just x, es {esInChars = xs}) 43 | evalOutputNumber n = EvalPure $ modify $ \es -> 44 | es {esOutNumbers = n : esOutNumbers es} 45 | evalOutputChar n = EvalPure $ modify $ \es -> 46 | es {esOutChars = n : esOutChars es} 47 | 48 | runEvalPure :: EvalPure a -> EvalState -> (Either EvalException a, EvalState) 49 | runEvalPure m = runState (runExceptT $ unEvalPure m) 50 | 51 | tests :: TestTree 52 | tests = testGroup "Turnstyle.Eval" 53 | [ testCase "examples/pi.png" $ do 54 | img <- autoScale <$> loadImage "examples/pi.png" 55 | let expr = parseImage Nothing img 56 | (result, finalState) = 57 | runState (runExceptT $ unEvalPure $ eval expr) emptyEvalState 58 | result @?= Right (Lit 0) 59 | esOutNumbers finalState @?= [Exact $ 5284 / 1681] 60 | ] 61 | -------------------------------------------------------------------------------- /hs/test/Turnstyle/Expr/Tests.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | module Turnstyle.Expr.Tests 3 | ( GenExpr (..) 4 | , DeBruijn (..) 5 | , toDeBruijn 6 | ) where 7 | 8 | import qualified Data.Map as M 9 | import qualified Data.Set as S 10 | import Data.Void (Void, absurd) 11 | import qualified Test.Tasty.QuickCheck as QC 12 | import Turnstyle.Expr 13 | import Turnstyle.Prim 14 | 15 | newtype GenExpr = GenExpr {unGenExpr :: Expr () Void Int} deriving (Show) 16 | 17 | instance QC.Arbitrary GenExpr where 18 | arbitrary = GenExpr <$> genExpr 0 19 | 20 | shrink (GenExpr expr) = case expr of 21 | App ann f x -> map GenExpr $ 22 | [f, x] ++ 23 | [App ann f' x | f' <- unGenExpr <$> QC.shrink (GenExpr f)] ++ 24 | [App ann f x' | x' <- unGenExpr <$> QC.shrink (GenExpr x)] 25 | Lam ann v b -> map GenExpr $ 26 | [b | not (v `S.member` freeVars b)] ++ 27 | [Lam ann v b' | b' <- unGenExpr <$> QC.shrink (GenExpr b)] 28 | _ -> [] 29 | 30 | genExpr :: Int -> QC.Gen (Expr () Void Int) 31 | genExpr fresh = QC.oneof $ 32 | [ App () <$> (genExpr fresh) <*> (genExpr fresh) 33 | , do 34 | v <- QC.choose (0, fresh) 35 | body <- genExpr (if v == fresh then v + 1 else fresh) 36 | pure $ Lam () v body 37 | , Prim () <$> QC.elements knownPrims 38 | , Lit () <$> QC.choose (1, 20) 39 | , Id () <$> genExpr fresh 40 | ] ++ 41 | if fresh > 0 then [Var () <$> QC.choose (0, fresh - 1)] else [] 42 | 43 | data DeBruijn 44 | = DbApp DeBruijn DeBruijn 45 | | DbLam DeBruijn 46 | | DbVar Int 47 | | DbPrim Prim 48 | | DbLit Integer 49 | deriving (Eq, Show) 50 | 51 | toDeBruijn :: forall ann v. Ord v => Expr ann Void v -> Maybe DeBruijn 52 | toDeBruijn = go M.empty 53 | where 54 | go :: M.Map v Int -> Expr ann Void v -> Maybe DeBruijn 55 | go vars (App _ f x) = DbApp <$> go vars f <*> go vars x 56 | go vars (Lam _ v b) = DbLam <$> go (M.insert v 1 $ fmap succ vars) b 57 | go vars (Var _ v) = DbVar <$> M.lookup v vars 58 | go _ (Prim _ l) = pure $ DbPrim l 59 | go _ (Lit _ l) = pure $ DbLit l 60 | go vars (Id _ e) = go vars e 61 | go _ (Err _ e) = absurd e 62 | -------------------------------------------------------------------------------- /hs/test/Turnstyle/Parse/Tests.hs: -------------------------------------------------------------------------------- 1 | module Turnstyle.Parse.Tests 2 | ( tests 3 | ) where 4 | 5 | import Data.Either.Validation (Validation (..)) 6 | import Data.List.NonEmpty (NonEmpty (..)) 7 | import Data.Void (Void) 8 | import Test.Tasty (TestTree, testGroup) 9 | import Test.Tasty.HUnit (testCase, (@?=)) 10 | import Turnstyle.Expr 11 | import Turnstyle.Expr.Tests 12 | import Turnstyle.JuicyPixels (loadImage) 13 | import Turnstyle.Parse (parseImage) 14 | import Turnstyle.Prim 15 | import Turnstyle.Scale (autoScale) 16 | 17 | data Error = ParseError | CycleError 18 | 19 | tests :: TestTree 20 | tests = testGroup "Turnstyle.Parse" 21 | [ example "examples/minimal.png" $ 22 | num_sub (lit 8) (lit 8 :: Expr () Void Int) 23 | 24 | , example "examples/pi.png" $ out_num 25 | (num_div 26 | (lit 1321 :: Expr () Void Int) 27 | (app 28 | (lam 0 (app 29 | (lam 1 (num_mul (var 1) (var 1))) 30 | [num_div (var 0) (lit 2)])) 31 | [lit 41])) 32 | (num_sub (lit 1) (lit 1)) 33 | 34 | , example "examples/rev.png" $ app 35 | ((lam "newline") 36 | (app 37 | (yc) 38 | [ lam "rec" $ lam "acc" $ in_char 39 | (lam "c" $ cmp_eq 40 | (var "c") 41 | (var "newline") 42 | (app (var "acc") 43 | [out_char (var "newline") (app (var "rec") [lam "x" (var "x")])]) 44 | (app (var "rec") 45 | [lam "final" (out_char (var "c") (app (var "acc") [var "final"]))])) 46 | (num_sub (var "newline") (var "newline")) 47 | , lam "x" (var "x") 48 | ])) 49 | [lit 10] 50 | 51 | , testCase "examples/loop.png" $ do 52 | img <- autoScale <$> loadImage "examples/loop.png" 53 | let parsed = mapErr (const ParseError) (parseImage Nothing img) 54 | case checkErrors (checkCycles (const CycleError) parsed) of 55 | Failure ((_, CycleError) :| []) -> pure () 56 | _ -> error "expected a CycleError" 57 | ] 58 | where 59 | example :: Ord v => FilePath -> Expr () Void v -> TestTree 60 | example path expected = testCase path $ do 61 | img <- autoScale <$> loadImage path 62 | case checkErrors (parseImage Nothing img) of 63 | Failure errs -> fail $ show errs 64 | Success expr -> toDeBruijn expr @?= toDeBruijn expected 65 | 66 | app f xs = foldl (App ()) f xs 67 | lam = Lam () 68 | var = Var () 69 | prim = Prim () 70 | lit = Lit () 71 | 72 | in_char k l = app (prim $ PIn InChar) [k, l] 73 | out_num x k = app (prim $ POut OutNumber) [x, k] 74 | out_char x k = app (prim $ POut OutChar) [x, k] 75 | 76 | num_sub x y = app (prim $ PNumOp NumOpSubtract) [x, y] 77 | num_mul x y = app (prim $ PNumOp NumOpMultiply) [x, y] 78 | num_div x y = app (prim $ PNumOp NumOpDivide) [x, y] 79 | 80 | cmp_eq x y t f = app (prim $ PCompare CmpEq) [x, y, t, f] 81 | 82 | yc = lam "f" $ app 83 | (lam "x" (app (var "f") [app (var "x") [var "x"]])) 84 | [lam "x" (app (var "f") [app (var "x") [var "x"]])] 85 | -------------------------------------------------------------------------------- /hs/test/Turnstyle/Quattern/Tests.hs: -------------------------------------------------------------------------------- 1 | module Turnstyle.Quattern.Tests 2 | ( tests 3 | ) where 4 | 5 | import Data.Foldable (for_) 6 | import Test.Tasty (TestTree, testGroup) 7 | import Test.Tasty.HUnit (testCase, (@?=)) 8 | import Turnstyle.Quattern (quattern) 9 | 10 | tests :: TestTree 11 | tests = testGroup "Turnstyle.Quattern" 12 | [ testCase "quattern . show" $ 13 | for_ [minBound .. maxBound] $ \q -> case show q of 14 | [x, y, z, w] -> quattern x y z w @?= q 15 | _ -> fail "bad quattern" 16 | ] 17 | -------------------------------------------------------------------------------- /hs/test/Turnstyle/Text/Tests.hs: -------------------------------------------------------------------------------- 1 | module Turnstyle.Text.Tests 2 | ( tests 3 | ) where 4 | 5 | import Test.Tasty (TestTree, testGroup) 6 | import Test.Tasty.HUnit (testCase, (@=?)) 7 | import qualified Test.Tasty.QuickCheck as QC 8 | import Turnstyle.Expr.Tests 9 | import Turnstyle.Text 10 | import qualified Turnstyle.Text.Sugar as Sugar 11 | 12 | tests :: TestTree 13 | tests = testGroup "Turnstyle.Text" 14 | [ QC.testProperty "parse . pretty" $ \(GenExpr expr) -> 15 | case parseExpr (prettyExpr expr) of 16 | Left _ -> False 17 | Right parsed -> toDeBruijn expr == toDeBruijn parsed 18 | 19 | , testCase "comments" $ 20 | let input = unlines 21 | [ "# Leading comment" 22 | , "1 # EOL comment" 23 | , "# Trailing comment" 24 | ] in 25 | Right (Sugar.Lit () 1) @=? 26 | fmap (const ()) <$> (parseSugar "test input" input) 27 | 28 | , testCase "comment EOF" $ 29 | Right (Sugar.Lit () 1) @=? 30 | fmap (const ()) <$> parseSugar "test input" "1 # Trailing comment" 31 | ] 32 | where 33 | parseExpr input = 34 | sugarToExpr (\_ _ -> error "imports not supported") <$> 35 | parseSugar "test input" input 36 | -------------------------------------------------------------------------------- /shell.nix: -------------------------------------------------------------------------------- 1 | { pkgs ? import { } }: 2 | pkgs.mkShell { 3 | inputsFrom = [ (import ./default.nix).env ]; 4 | packages = [ 5 | pkgs.cabal-install 6 | pkgs.entr 7 | pkgs.git 8 | pkgs.stylish-haskell 9 | ]; 10 | } 11 | -------------------------------------------------------------------------------- /spec/README.md: -------------------------------------------------------------------------------- 1 | --- 2 | title: Turnstyle Specification 3 | author: Jasper Van der Jeugt 4 | version: v0.0.1 5 | --- 6 | 7 | The program is encoded as an image. A **lossless** image format should be used 8 | so exact colors are preserved. The use of [PNG] is recommended because of its 9 | wide support and decent compression. 10 | 11 | We assume that the reader is somewhat familiar with Lambda Calculus. 12 | If you want to learn more about Lambda Calculus, we recommend 13 | [this video with Graham Hutton](https://www.youtube.com/watch?v=eis11j_iGMs) or 14 | [this paper by Raúl Rojas](https://personal.utdallas.edu/~gupta/courses/apl/lambda.pdf) 15 | for a good introduction. 16 | 17 | # Syntax 18 | 19 | Turnstyle programs are evaluated by reading and evaluating **expressions** from 20 | the image. An expression is read using a given **position** (represented as 21 | integral _(x, y)_ coordinates) and **heading** (right, down, left or up). 22 | 23 | The top-level expression of a program is found at the center of the left side of 24 | the image _(0, floor (image height / 2))_, and the initial heading is **right**. 25 | 26 | To read an expression, we consider the **Turnstyle shape** of the pixels 27 | surrounding the current **position** and facing the current **heading**. 28 | If any of these four pixels lies outside of the image, the program should 29 | terminate with an error. 30 | 31 | Here is the Turnstyle shape illustrated for all four headings, with the current 32 | position indicated by the small circle, and the heading represented using an 33 | arrow: 34 | 35 | ![Headings](enter.svg) 36 | 37 | For brevity, in all further illustrations in the specification we will assume we 38 | are heading right. 39 | 40 | We use the following names to refer to the four pixels that make up the 41 | Turnstyle shape: **L**eft, **C**enter, **F**ront, and **R**ight. 42 | 43 | ![Pixel names](label.svg) 44 | 45 | Turnstyle programs can use _any colors_, as long as we can compare two colors 46 | for (in-)equality. This gives us **15 unique patterns**. Here is a cheatsheet: 47 | 48 | ![Cheatsheet](cheatsheet.svg) 49 | 50 | The pattern determines the expression that we read evaluate. There are five 51 | kinds of expressions: 52 | 53 | 1. [Variables](#variables) 54 | 2. [Lambda abstraction](#lambda-abstraction) 55 | 3. [Function application](#function-application) 56 | 4. [Symbols](#symbols) ([primitive operations](#primitives) and numeric literals) 57 | 5. [Identity](#identity) (no-ops) 58 | 59 | ## Variables 60 | 61 | In Turnstyle, we use _colors_ as variable names. Depending on the pattern, 62 | we pick the color of the pixel indicated by the letters LCFR: 63 | 64 | ![Variables](var.svg) 65 | 66 | This evaluates to the value assigned to the variable. If the variable is 67 | unassigned, the program should terminate with an error. 68 | 69 | ## Lambda abstraction 70 | 71 | Lambda abstraction evaluates to the anonymous function _(λv.e)_, where the 72 | variable _v_ is the color of the pixel indicated with the letters LCR, and _e_ 73 | is the expression at the Turnstyle shape indicated by the arrow. 74 | 75 | ![Lambda abstraction](lam.svg) 76 | 77 | ## Function application 78 | 79 | Function application evaluates the expression _(f x)_, 80 | where _f_ is the Turnstyle shape indicated by the solid arrow (→) 81 | and _x_ is the Turnstyle shape indicated by the dashed arrow (⇢). 82 | 83 | ![Function application](app.svg) 84 | 85 | If you visualize standing on the image and looking towards the front, the 86 | left-hand side of the application will always be to the left of the right-hand 87 | side of the application. 88 | 89 | ## Symbols 90 | 91 | Symbols encode literals in the program. We compare the relative **areas** of 92 | the left, front and right pixels. 93 | 94 | An **area** is defined as the number of pixels in a contiguous color region. 95 | Pixels of the same color that only touch diagonally are **not** considered 96 | contiguous. 97 | 98 | ![Symbols](symbol.svg) 99 | 100 | Just like [application](#function-application) patterns in Turnstyle, symbols 101 | are read in a clockwise direction. 102 | The kind of symbol is defined by _area(L)_. 103 | 104 | - If _area(L) = 1_, the Turnstyle evaluates to a **numeric** literal 105 | of the integer value _area(F)^area(R)_. Commonly, _area(R)_ is 1. 106 | - If _area(L) = 2_, the Turnstyle evaluates to a **primitive function**. 107 | In this case, _area(F)_ determines the **primitive module**, 108 | and _area(R)_ determines the **primitive opcode**. 109 | See also [Primitives](#primitives). 110 | - Symbols with _area(L) > 2_ are reserved for future updates to the 111 | specification. 112 | 113 | ## Identity 114 | 115 | For all other patterns, we evaluate the expression at the Turnstyle indicated by 116 | the arrow (→). You can visualize this as following the color of the line. 117 | 118 | ![Identity](id.svg) 119 | 120 | # Semantics 121 | 122 | ## Primitives 123 | 124 | This is an overview of the different primitive functions and what they do. 125 | 126 | ### Input (module=1) 127 | 128 | | Opcode | Description | 129 | | :----- | :----------------------------------------------------------------------------------------------------------------------------------------------------- | 130 | | 1 | _((`in_num` k) l)_ reads a number `x` from `stdin`, then evaluates _(k x)_. If `stdin` is closed or an exception occurs, _l_ is evaluated instead. | 131 | | 2 | _((`in_char` k) l)_ reads a character `c` from `stdin`, then evaluates _(k c)_. If `stdin` is closed or an exception occurs, _l_ is evaluated instead. | 132 | 133 | ### Output (module=2) 134 | 135 | | Opcode | Primitive | 136 | | :----- | :-------------------------------------------------------------------------------------------- | 137 | | 1 | _((`out_number` x) k)_ outputs `x` as a number to `stdout`, and then evaluates _k_. | 138 | | 2 | _((`out_char` x) k)_ outputs `x` as an Unicode character to `stdout`, and then evaluates _k_. | 139 | 140 | ### Numerical operations (module=3) 141 | 142 | | Opcode | Primitive | 143 | | :----- | :--------------------------------------------------------------------------------- | 144 | | 1 | _((`num_add` x) y)_ evaluates to _x + y_. | 145 | | 2 | _((`num_sub` x) y)_ evaluates to _x - y_. | 146 | | 3 | _((`num_mul` x) y)_ evaluates to _x * y_. | 147 | | 4 | _((`num_div` x) y)_ evaluates to _x / y_. | 148 | | 5 | _((`num_mod` x) y)_ evaluates to _x % y_. Both operands must be integral numbers. | 149 | 150 | ### Comparisons (module=4) 151 | 152 | Turnstyle has no primitive boolean type, and uses [Church encoding] instead, 153 | i.e. _true = λxy.x_ and _false = λxy.y_. 154 | 155 | | Opcode | Primitive | 156 | | :----- | :----------------------------------------------------------------------- | 157 | | 1 | _((((`cmp_eq` x) y) t) f)_ evaluates _t_ if _x = y_, and _f_ otherwise. | 158 | | 2 | _((((`cmp_lt` x) y) t) f)_ evaluates _t_ if _x < y_, and _f_ otherwise. | 159 | | 3 | _((((`cmp_gt` x) y) t) f)_ evaluates _t_ if _x > y_, and _f_ otherwise. | 160 | | 4 | _((((`cmp_lte` x) y) t) f)_ evaluates _t_ if _x ≤ y_, and _f_ otherwise. | 161 | | 5 | _((((`cmp_gte` x) y) t) f)_ evaluates _t_ if _x ≥ y_, and _f_ otherwise. | 162 | 163 | ### Inexact Math (module=5) 164 | 165 | 166 | | Opcode | Primitive | 167 | | :----- | :-------------------------------------------------------- | 168 | | 1 | _(`inexact_sqrt` x)_ evaluates to the square root of _x_. | 169 | 170 | ## Evaluation order 171 | 172 | Turnstyle uses _call-by-need_ evaluation. 173 | The interpreter or compiler is free to use other evaluation strategies and 174 | optimizations, but the semantics of the [primitives](#primitives) must be 175 | respected; and effect ordering must be consistent with _call-by-need_ 176 | evaluation. For example: 177 | 178 | - Evaluating `((((cpm_eq 1) 2) t) f)` should not evaluate `t`. 179 | - Evaluating `((λf. f (f 1)) (out_num 2))` should output 2 twice before 180 | producing exit code 1. 181 | 182 | ## Cyclic programs 183 | 184 | The Turnstyle position and direction can be manipulated in a way that it ends up 185 | in a previously visited shape. In that case, there is no finite corresponding 186 | expression in the lambda calculus. 187 | 188 | ## Precision 189 | 190 | Turnstyle borrows its numeric precision concepts from [Scheme][Scheme 191 | Exactness]: 192 | 193 | > Scheme numbers are either exact or inexact. A number is exact if it was 194 | > written as an exact constant or was derived from exact numbers using only 195 | > exact operations. A number is inexact if it was written as an inexact 196 | > constant, if it was derived using inexact ingredients, or if it was derived 197 | > using inexact operations. Thus inexactness is a contagious property of a 198 | > number. 199 | 200 | The following primitives in Turnstyle are **inexact**: 201 | 202 | - `inexact_sqrt` 203 | 204 | [Church encoding]: https://en.wikipedia.org/wiki/Church_encoding 205 | [PNG]: http://libpng.org/pub/png/ 206 | [Scheme Exactness]: https://www.cs.cmu.edu/Groups/AI/html/r4rs/r4rs_8.html#SEC52 207 | -------------------------------------------------------------------------------- /spec/app.svg: -------------------------------------------------------------------------------- 1 | 2 | -------------------------------------------------------------------------------- /spec/enter.svg: -------------------------------------------------------------------------------- 1 | 2 | -------------------------------------------------------------------------------- /spec/id.svg: -------------------------------------------------------------------------------- 1 | 2 | -------------------------------------------------------------------------------- /spec/init.svg: -------------------------------------------------------------------------------- 1 | 2 | -------------------------------------------------------------------------------- /spec/label.svg: -------------------------------------------------------------------------------- 1 | 2 | RFCL -------------------------------------------------------------------------------- /spec/lam.svg: -------------------------------------------------------------------------------- 1 | 2 | RCL -------------------------------------------------------------------------------- /spec/symbol.svg: -------------------------------------------------------------------------------- 1 | 2 | RFL -------------------------------------------------------------------------------- /spec/var.svg: -------------------------------------------------------------------------------- 1 | 2 | RFCL -------------------------------------------------------------------------------- /turnstyle.cabal: -------------------------------------------------------------------------------- 1 | Cabal-version: 2.2 2 | Name: turnstyle 3 | Version: 0.1.0.0 4 | Description: Please see the README on GitHub at 5 | Homepage: https://github.com/jaspervdj/turnstyle#readme 6 | Bug-reports: https://github.com/jaspervdj/turnstyle/issues 7 | Author: Jasper Van der Jeugt 8 | Maintainer: m@jaspervdj.be 9 | Copyright: 2024 Jasper Van der Jeugt 10 | License: GPL-2.0-or-later 11 | License-file: LICENSE 12 | Build-type: Simple 13 | Extra-source-files: 14 | README.md 15 | 16 | Source-repository head 17 | type: git 18 | location: https://github.com/jaspervdj/turnstyle 19 | 20 | Library 21 | Hs-source-dirs: hs/lib 22 | Ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints 23 | Default-language: Haskell2010 24 | Exposed-modules: 25 | Turnstyle.Compile 26 | Turnstyle.Compile.Bound 27 | Turnstyle.Compile.Constraint 28 | Turnstyle.Compile.Contaminate 29 | Turnstyle.Compile.Paint 30 | Turnstyle.Compile.Expr 31 | Turnstyle.Compile.Recompile 32 | Turnstyle.Compile.Shake 33 | Turnstyle.Compile.Shape 34 | Turnstyle.Compile.SimulatedAnnealing 35 | Turnstyle.Compile.Solve 36 | Turnstyle.Eval 37 | Turnstyle.Expr 38 | Turnstyle.Image 39 | Turnstyle.JuicyPixels 40 | Turnstyle.Number 41 | Turnstyle.Main 42 | Turnstyle.Parse 43 | Turnstyle.Prim 44 | Turnstyle.Quattern 45 | Turnstyle.Scale 46 | Turnstyle.Text 47 | Turnstyle.Text.Parse 48 | Turnstyle.Text.Pretty 49 | Turnstyle.Text.Sugar 50 | Turnstyle.TwoD 51 | Build-depends: 52 | base >= 4.7 && < 5, 53 | containers >= 0.6 && < 0.7, 54 | data-default >= 0.7 && < 0.8, 55 | either >= 5.0 && < 5.1, 56 | JuicyPixels >= 3.3 && < 3.4, 57 | mtl >= 2.3 && < 2.4, 58 | optparse-applicative >= 0.18 && < 0.19, 59 | parsec >= 3.1 && < 3.2, 60 | random >= 1.2 && < 1.3 61 | 62 | Executable turnstyle 63 | Main-is: Main.hs 64 | Hs-source-dirs: hs/src 65 | Ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N 66 | Default-language: Haskell2010 67 | Build-depends: base, turnstyle 68 | 69 | Executable turnstyle-spec-figures 70 | Main-is: SpecFigures.hs 71 | Hs-source-dirs: hs/src 72 | Ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N 73 | Default-language: Haskell2010 74 | Build-depends: 75 | base >= 4.7 && < 5, 76 | diagrams-lib >= 1.4 && < 1.5, 77 | diagrams-svg >= 1.4 && < 1.5, 78 | turnstyle 79 | 80 | Executable turnstyle-annotate-examples 81 | Main-is: AnnotateExamples.hs 82 | Hs-source-dirs: hs/src 83 | Ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N 84 | Default-language: Haskell2010 85 | Build-depends: 86 | base >= 4.7 && < 5, 87 | blaze-svg >= 0.3 && < 0.4, 88 | bytestring >= 0.11 && < 0.12, 89 | directory >= 1.3 && < 1.4, 90 | filepath >= 1.4 && < 1.5, 91 | turnstyle, 92 | JuicyPixels >= 3.3 && < 3.4 93 | 94 | Executable turnstyle-recolor 95 | Main-is: Recolor.hs 96 | Hs-source-dirs: hs/src 97 | Ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N 98 | Default-language: Haskell2010 99 | Build-depends: 100 | base >= 4.7 && < 5, 101 | containers >= 0.6 && < 0.7, 102 | either >= 5.0 && < 5.1, 103 | JuicyPixels >= 3.3 && < 3.4, 104 | optparse-applicative >= 0.18 && < 0.19, 105 | turnstyle 106 | 107 | Executable turnstyle-website 108 | Main-is: Website.hs 109 | Hs-source-dirs: hs/src 110 | Ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N 111 | Default-language: Haskell2010 112 | Build-depends: 113 | base >= 4.7 && < 5, 114 | hakyll >= 4.16 && < 4.17, 115 | pandoc >= 3.1 && < 3.2, 116 | process >= 1.6 && < 1.7 117 | 118 | Test-suite turnstyle-test 119 | Type: exitcode-stdio-1.0 120 | Main-is: Main.hs 121 | Hs-source-dirs: hs/test 122 | Ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N 123 | Default-language: Haskell2010 124 | Other-modules: 125 | Turnstyle.Compile.Tests 126 | Turnstyle.Eval.Tests 127 | Turnstyle.Expr.Tests 128 | Turnstyle.Parse.Tests 129 | Turnstyle.Quattern.Tests 130 | Turnstyle.Text.Tests 131 | Build-depends: 132 | base >= 4.7 && < 5, 133 | containers >= 0.6 && < 0.7, 134 | either >= 5.0 && < 5.1, 135 | JuicyPixels >= 3.3 && < 3.4, 136 | mtl >= 2.3 && < 2.4, 137 | tasty >= 1.4 && < 1.5, 138 | tasty-hunit >= 0.10 && < 0.11, 139 | tasty-quickcheck >= 0.10 && < 0.11, 140 | turnstyle 141 | -------------------------------------------------------------------------------- /website/favicon.ico: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jaspervdj/turnstyle/f7054f1b9a3c0fdb311b0721bde96ba846971450/website/favicon.ico -------------------------------------------------------------------------------- /website/home.md: -------------------------------------------------------------------------------- 1 | Turnstyle is a graphical [esoteric programming language] loosely inspired by 2 | [Piet]. Both encode programs as images, however, the similarities end at the 3 | syntax level. 4 | 5 | Where Piet is really a stack machine in disguise, Turnstyle is an encoding of 6 | the (untyped) [Lambda calculus]. This allows for building more reusable images 7 | at a higher level of abstraction, while still keeping the specification small, 8 | making it relatively easy to develop new interpreters. 9 | 10 | This repository contains [the language specification](spec/), a reference 11 | implementation in Haskell, and a 12 | [simple JavaScript implementation](turnstyle.js). 13 | 14 | # Specification 15 | 16 | The cheatsheet below provides a high-level overview, for more details please 17 | consult [the Turnstyle Language Specification](spec/). 18 | 19 | ![Cheatsheet](spec/cheatsheet.svg) 20 | 21 | # Examples 22 | 23 | The starting Turnstyle shape is outlined. Click on the examples to run them in 24 | the browser. 25 | 26 | ## pi 27 | 28 | Prints an approximation of _pi_ by comparing the circle to its diameter: 29 | 30 | [![](examples/pi.svg)](examples/pi.png) 31 | 32 | ## rev 33 | 34 | Uses a [Y combinator] (indicated by the red rectangle in the top left) 35 | and [continuation-passing style] to implement the Unix `rev` program. 36 | Type lines into the terminal to revert them. 37 | 38 | [![](examples/rev.svg)](examples/rev.png) 39 | 40 | ## loop 41 | 42 | Of course, fixed-point combinators are a primitive tool necessary to compensate 43 | for the limitations of one-dimensional programming. In two-dimensional 44 | programs, we can implement recursion using a more visually intuitive approach. 45 | This program prints the sequence of natural numbers: 46 | 47 | [![](examples/loop.svg)](examples/loop.png) 48 | 49 | # Design Principles 50 | 51 | In roughly this order: 52 | 53 | 1. In the spirit of Lambda calculus, the specification should prioritize 54 | simplicity and clarity. 55 | - Have a single numeric type that support exact as well as inexact 56 | operations. 57 | - Referential transparency will allow users to share and reuse images. 58 | - Prefer Church encoding over introducing new built-in types whenever 59 | possible. 60 | 2. Preserve the suspension of disbelief concerning using this for real 61 | programs: 62 | - Allow for building fast compilers, type systems and tooling. 63 | - Have an extensible system for primitives so things like networking and 64 | file IO can be added in. 65 | - An Array type could be added for efficiency, since there is no good way 66 | to build _O(1)_ indexing using Church encoding. 67 | 3. Allow plenty of creative freedom in the choice of colors and shapes. 68 | - Make sure it possible to create very dense images where specific pixels 69 | are reused in several expressions. 70 | 4. Represent integers as areas as a nod to Piet (as a side effect, 0 does not 71 | exist as a literal). 72 | 73 | [continuation-passing style]: https://en.wikipedia.org/wiki/Continuation-passing_style 74 | [esoteric programming language]: https://en.wikipedia.org/wiki/Esoteric_programming_language 75 | [Lambda calculus]: https://en.wikipedia.org/wiki/Lambda_calculus 76 | [Piet]: https://www.dangermouse.net/esoteric/piet.html 77 | [Y combinator]: https://en.wikipedia.org/wiki/Fixed-point_combinator 78 | -------------------------------------------------------------------------------- /website/playground.html: -------------------------------------------------------------------------------- 1 | 2 | 3 |
Please upload a file…
4 | 5 | 6 | 7 | 8 | 9 |
10 | 11 | 12 |
13 | 14 | 15 | 16 | 17 | 103 | -------------------------------------------------------------------------------- /website/preview.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jaspervdj/turnstyle/f7054f1b9a3c0fdb311b0721bde96ba846971450/website/preview.png -------------------------------------------------------------------------------- /website/preview.svg: -------------------------------------------------------------------------------- 1 | 2 | 20 | 39 | 41 | 44 | 54 | 57 | 58 | 68 | 71 | 72 | 82 | 85 | 86 | 96 | 99 | 100 | 110 | 113 | 114 | 124 | 127 | 128 | 138 | 141 | 142 | 154 | 157 | 158 | 168 | 171 | 172 | 182 | 185 | 186 | 196 | 199 | 200 | 210 | 213 | 214 | 224 | 227 | 228 | 238 | 241 | 242 | 252 | 255 | 256 | 266 | 269 | 270 | 280 | 283 | 284 | 296 | 299 | 300 | 310 | 313 | 314 | 324 | 327 | 328 | 338 | 341 | 342 | 352 | 355 | 356 | 366 | 369 | 370 | 380 | 383 | 384 | 394 | 397 | 398 | 408 | 411 | 412 | 422 | 425 | 426 | 438 | 441 | 442 | 452 | 455 | 456 | 466 | 469 | 470 | 471 | 472 | -------------------------------------------------------------------------------- /website/style.css: -------------------------------------------------------------------------------- 1 | html { 2 | font-family: sans-serif; 3 | font-size: 16px; 4 | line-height: 150%; 5 | margin: 12px; 6 | background: #f9f6ec; 7 | color: #222; 8 | } 9 | 10 | body { 11 | max-width: 720px; 12 | margin: 0px auto 48px auto; 13 | } 14 | 15 | header { 16 | display: flex; 17 | justify-content: center; 18 | align-items: center; 19 | font-size: 30px; 20 | margin: 1em; 21 | } 22 | 23 | header img { 24 | max-height: 36px; 25 | margin-right: 12px; 26 | } 27 | 28 | nav { 29 | font-size: 18px; 30 | text-align: center; 31 | margin: 1em 0em; 32 | } 33 | 34 | nav a { 35 | margin: 0 .2em; 36 | color: #222; 37 | } 38 | 39 | nav a.active { 40 | font-weight: bold; 41 | text-decoration: none; 42 | } 43 | 44 | h1 { 45 | font-size: 24px; 46 | font-weight: normal; 47 | margin: 2em 0em 0.5em 0em; 48 | } 49 | 50 | h2 { 51 | font-size: 20px; 52 | font-weight: normal; 53 | margin: 1em 0em 0.5em 0em; 54 | } 55 | 56 | h3 { 57 | font-size: 18px; 58 | font-weight: normal; 59 | margin: 1em 0em 0.5em 0em; 60 | opacity: 70%; 61 | } 62 | 63 | .header-section-number:after { 64 | content: "."; 65 | } 66 | 67 | img { 68 | max-width: 90%; 69 | } 70 | 71 | th, td { 72 | padding: 0em 0.5em; 73 | vertical-align: top; 74 | } 75 | 76 | th { 77 | opacity: 70%; 78 | font-weight: normal; 79 | } 80 | 81 | p:has(a[href^="examples/"]) { 82 | text-align: center; 83 | } 84 | 85 | figure { 86 | text-align: center; 87 | margin-bottom: 2em; 88 | } 89 | 90 | blockquote { 91 | border-left: 4px solid #bbb; 92 | padding-left: 1em; 93 | margin-left: 0; 94 | } 95 | 96 | .interpreter { 97 | text-align: center; 98 | } 99 | 100 | .interpreter svg { 101 | max-width: 90%; 102 | height: auto; 103 | margin-bottom: .5em; /* Some space in between svg and terminal */ 104 | } 105 | 106 | .interpreter .terminal { 107 | text-align: left; 108 | display: block; 109 | overflow-y: scroll; 110 | max-height: 5em; 111 | background-color: #2228; 112 | color: #fff; 113 | padding: .5em; 114 | } 115 | 116 | .interpreter .terminal pre { 117 | margin: 0px; 118 | } 119 | 120 | .interpreter .terminal textarea { 121 | padding: 0px; 122 | margin: 0px; 123 | opacity: 0; 124 | width: 0px; 125 | height: 0px; 126 | border: none; 127 | } 128 | 129 | .interpreter .terminal:has(textarea:focus) .cursor { 130 | animation: cursor 1s linear infinite; 131 | } 132 | 133 | .interpreter .terminal .cursor { 134 | display: inline-block; 135 | height: 1.2em; 136 | margin-bottom: -0.1em; 137 | width: 0.5em; 138 | background: #fff; 139 | } 140 | 141 | @keyframes cursor { 142 | 0% { background: transparent; } 143 | 50% { background: inherit; } 144 | } 145 | 146 | input { 147 | margin: .5em 0px; 148 | } 149 | -------------------------------------------------------------------------------- /website/template.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | $title$ 15 | 16 | 17 |
18 | 19 | Turnstyle 20 |
21 | 27 | $body$ 28 | 42 | 43 | 44 | -------------------------------------------------------------------------------- /website/turnstyle.svg: -------------------------------------------------------------------------------- 1 | 2 | --------------------------------------------------------------------------------