From 7b9ca4c7af44b5302cc20674b8fb6ed252c9813b Mon Sep 17 00:00:00 2001 From: F Date: Sat, 14 May 2022 01:17:43 +0100 Subject: [PATCH] to infinity and beyond! --- Space.cabal | 18 ++++ flake.nix | 13 ++- space-ship/REPL.hs | 129 +++++++++++++++++++++++++++++ space-ship/Space/Interface/REPL.hs | 77 +++++++++++++++++ 4 files changed, 234 insertions(+), 3 deletions(-) create mode 100644 space-ship/REPL.hs create mode 100644 space-ship/Space/Interface/REPL.hs diff --git a/Space.cabal b/Space.cabal index 687ee1f..8e6f93a 100644 --- a/Space.cabal +++ b/Space.cabal @@ -140,6 +140,24 @@ library -- -- ghc-options: -threaded -rtsopts +common Graphics + build-depends: + gloss + , async + , stm + , colour + , hashable + hs-source-dirs: space-ship + other-modules: Space.Interface.REPL + +executable space-ship + import: Extensions + import: Graphics + import: Dependencies + import: Language + import: Config + main-is: REPL.hs + common Repl hs-source-dirs: repl other-modules: Space.Interface.REPL diff --git a/flake.nix b/flake.nix index 3d256dd..2a796d6 100644 --- a/flake.nix +++ b/flake.nix @@ -14,7 +14,14 @@ config.allowBroken = true; }; - additionalPckgs = with pkgs; [ nixfmt rlwrap ]; + # this fixes dynamic linking of glibc on my laptop + space-ship = with pkgs; writeShellScriptBin "space-ship" '' + export LD_LIBRARY_PATH=${glibc}/lib + cabal run space-ship + ''; + + additionalPckgs = with pkgs; [ nixfmt rlwrap space-ship ]; + additionalHaskellPckgs = with pkgs.haskellPackages; [ structured-haskell-mode @@ -38,8 +45,8 @@ root = self; withHoogle = true; modifier = drv: - pkgs.haskell.lib.addBuildTools drv - (additionalHaskellPckgs ++ additionalPckgs); + pkgs.haskell.lib.addBuildTools drv + (additionalHaskellPckgs ++ additionalPckgs); }; in { # Used by `nix build` & `nix run` (prod exe) diff --git a/space-ship/REPL.hs b/space-ship/REPL.hs new file mode 100644 index 0000000..c588626 --- /dev/null +++ b/space-ship/REPL.hs @@ -0,0 +1,129 @@ +module Main where +import Control.Lens +import Control.Monad +import Prettyprinter (pretty) +import Space +import Space.Interface.REPL +import Space.Evaluator.Implementation.Pure +import Data.Map (Map) +import Data.Map qualified as Map +import Data.Foldable (toList) +import Data.Colour.RGBSpace.HSL +import Data.Colour.RGBSpace +import Graphics.Gloss.Interface.IO.Simulate +import Graphics.Gloss.Data.Color +import Control.Concurrent.STM.TChan +import Control.Concurrent.Async +import Prelude hiding ( lines ) +import Control.Monad (void) +import Control.Monad.STM +import System.Exit (exitSuccess) +import Data.Hashable + +main :: IO () +main = do + ch <- newTChanIO + putStrLn (spaceiStdConfig ^. siWelcome) + repl <- async (dispatch ch mempty) + viz <- async (visualizer ch) + _ <- wait repl + exitSuccess + + +cellSize :: Float +cellSize = 64.0 + +visualizer :: TChan MachineMemory -> IO () +visualizer ch = do + let initialstate = blank + simulateIO window background fps initialstate render update + where + window = InWindow "Space" (1280, 1280) (0, 0) + background = white + fps = 12 + render xs = pure xs + update _ _ p = do + res <- atomically $ tryReadTChan ch + case res of + Nothing -> pure p + Just so -> pure $ Rotate (180.0) $ paint $ viz so + +newtype Cell = Cell ((Int,Int),Picture) + +paint :: Cell -> Picture +paint (Cell (_,p)) = p + +instance Semigroup Cell where + (<>) (Cell ((lw,lh),lp)) (Cell ((rw,rh),rp)) = + Cell ((lw + rw, max lh rh) + , Translate (cellSize*(fromIntegral (lw-rw))/2.0) 0 + (Pictures [Translate (-cellSize*(fromIntegral lw)/2.0) 0 lp + ,Translate (cellSize*(fromIntegral rw)/2.0) 0 rp + ] + ) + ) + +instance Monoid Cell where + mempty = Cell ((0,0),blank) + +pivot :: Cell -> Cell +pivot (Cell ((w,h),p)) = Cell ((h,w),Rotate (90.0) p) + + +class Viz a where + viz :: a -> Cell + +instance Viz Int where + viz i = Cell ((1,1),Pictures [cell i,Scale 0.2 0.2 $ Text (show i)]) + +instance Viz Char where + viz i = Cell ((1,1),Pictures [cell i,Scale 0.2 0.2 $ Text [i]]) + +instance Viz Variable where + viz (Variable s) = Cell ((1,1), Pictures [cell s, Scale 0.2 0.2 $ Text s]) + +instance Viz Location where + viz DLocation = Cell ((1,1), Pictures [cell (show DLocation), Scale 0.2 0.2 $ Text "@"]) + viz (Location l) = Cell ((1,1), Pictures [cell l, Scale 0.2 0.2 $ Text l]) + +instance Viz Term where + viz SEmpty = Cell ((1,1),Pictures [cell (show SEmpty),Scale 0.4 0.4 (Text "*")]) + viz (SVariable v t) = viz v <> viz t + viz (SInteger i t) = viz i <> viz t + viz (SChar c t) = viz c <> viz t + viz (SPush t1 l t2) = viz t1 <> viz l <> viz t2 + viz (SPop v l t) = viz v <> viz l <> viz t + viz (SPopT v l _s t) = viz v <> viz l <> viz t + +instance (Viz l, Viz r) => Viz (l,r) where + viz (l,r) = viz l <> viz r + +instance (Viz k, Viz v) => Viz (Map k v) where + viz m = mconcat (pivot . viz <$> Map.toList m) + +instance Viz a => Viz (Stack a) where + viz (Stack s) = mconcat (pivot . viz <$> toList s) + +instance Viz MachineMemory where + viz (Memory sp st bi) = mconcat (pivot <$> [viz sp,viz st, viz bi]) + +cell :: Hashable a => a -> Picture +cell a = Pictures [ (color (hashColor a) (rectangleSolid cellSize cellSize)) + , Translate 0 (2.0 - cellSize/2.0) (color black (rectangleSolid cellSize 4.0)) + ] + +hashColor :: Hashable a => a -> Color +hashColor a = + let ha = abs (hash a) + v = [0.35, 0.5, 0.65] + h = fromIntegral (ha `rem` 359) + s = v!!((ha `div` 360) `rem` 3) + l = v!!((ha `div` 3) `rem` 3) + (RGB r g b) = hsl h s l + in normalizeColor r g b 1.0 + +normalizeColor :: Float -> Float -> Float -> Float -> Color +normalizeColor r g b a + = let m = maximum [r, g, b] + in makeColor (r / m) (g / m) (b / m) a + diff --git a/space-ship/Space/Interface/REPL.hs b/space-ship/Space/Interface/REPL.hs new file mode 100644 index 0000000..f1b1d9e --- /dev/null +++ b/space-ship/Space/Interface/REPL.hs @@ -0,0 +1,77 @@ +module Space.Interface.REPL where + +import Control.Lens +import Prettyprinter +import Space +import Space.Evaluator.Implementation.Pure +import Graphics.Gloss +import Control.Concurrent.STM.TChan +import Control.Monad.STM + +data SpaceiConfig = SpaceiConfig + { _siWelcome :: String + , _siPrompt :: String + , _siBye :: String + , _siHelp :: String + } + +makeLenses ''SpaceiConfig + +siVersion = "v0.0.0 " + +spaceiStdConfig = + SpaceiConfig + { _siWelcome = + mconcat $ + (<> "\n") + <$> [ "Space.i, version: " ++ siVersion + , ":h for help prompt." + , "Happy Hacking!" + ] + , _siPrompt = "γ> " + , _siBye = "See you later!\n" + , _siHelp = + mconcat $ + (<> "\n") + <$> [":l to load a file", ":q to quit", ":h for help"] + } + +replEval :: String -> MachineMemory -> (String, MachineMemory) +replEval s mem = + let pr = parseTerm s + in case pr of + Left e -> (show e, mem) + Right term -> case eval mem term of + Left e -> (show . pretty $ e, mem) + Right mem' -> (show . pretty $ mem', mem') + +step :: MachineMemory -> String -> IO MachineMemory +step mem input = do + let (out, mem') = replEval input mem + print (pretty out) + pure mem' + +data Command = CInterpret | CQuit | CLoad | CHelp + +readCommand :: String -> (Command, String) +readCommand = \case + (':' : c : ss) -> + case c of + 'q' -> (,) CQuit mempty + 'l' -> (,) CLoad ss + 'h' -> (,) CHelp mempty + _ -> (,) CHelp mempty + x -> (CInterpret, x) + +dispatch :: TChan MachineMemory -> MachineMemory -> IO () +dispatch ch mem = do + atomically $ writeTChan ch mem + (comm, input) <- readCommand <$> getLine + exeCommand ch comm mem input + +exeCommand :: TChan MachineMemory -> Command -> MachineMemory -> String -> IO () +exeCommand ch = \case + CQuit -> \_ _ -> putStrLn (spaceiStdConfig ^. siBye) + CInterpret -> \m s -> step m s >>= dispatch ch + CLoad -> \m (_ : path) -> readFile path >>= step m >>= dispatch ch + cHelp -> \m _ -> putStrLn (spaceiStdConfig ^. siHelp) >> dispatch ch m