Add RAM

docs/CHANGELOG.md

@@ -1,5 +1,9 @@
 # 📅 Revision history for HelCam
 
+## 0.6.2.0  -- 2021-02-23
+
+* RAM encapsulation
+
 ## 0.6.1.0  -- 2021-02-08
 
 * Use `relude` library

helcam.cabal

@@ -3,7 +3,7 @@ cabal-version:       2.2
 -- documentation, see http://eta-lang.org/docs/
 
 name:                helcam
-version:             0.6.1.0
+version:             0.6.2.0
 
 synopsis:            Heavenly Esoteric Little Concrete Absolute Machine
 description:         Please see the README on GitHub at <https://github.com/helvm/helcam#readme>
@@ -30,13 +30,17 @@ library
         HelVM.HelCam.Machines.BrainFuck.Symbol
         HelVM.HelCam.Machines.BrainFuck.TableOfInstructions
 
+        HelVM.HelCam.Machines.SubLeq.Symbol
+
         HelVM.HelCam.Machines.WhiteSpace.EvaluatorUtil
         HelVM.HelCam.Machines.WhiteSpace.Lexer
   exposed-modules:
         HelVM.HelCam.Common.FilterIf0
         HelVM.HelCam.Common.MockIO
         HelVM.HelCam.Common.OrError
-        HelVM.HelCam.Common.Tape
+        HelVM.HelCam.Common.RAM.IntMapRAM
+        HelVM.HelCam.Common.RAM.ListRAM
+        HelVM.HelCam.Common.RAM.SeqRAM
         HelVM.HelCam.Common.Util
         HelVM.HelCam.Common.WrapperIO
 
@@ -56,7 +60,6 @@ library
         HelVM.HelCam.Machines.SubLeq.Evaluator
         HelVM.HelCam.Machines.SubLeq.Evaluator.InteractEvaluator
         HelVM.HelCam.Machines.SubLeq.Evaluator.MonadicEvaluator
-        HelVM.HelCam.Machines.SubLeq.EvaluatorUtil
         HelVM.HelCam.Machines.SubLeq.Lexer
 
         HelVM.HelCam.Machines.WhiteSpace.Evaluator
@@ -70,6 +73,7 @@ library
   build-depends:
       base
     , relude               == 0.7.0.0
+    , containers           == 0.6.2.1
     , split
     , data-default
   mixins:
@@ -84,14 +88,17 @@ test-suite helcam-test
   main-is:             Test.hs
   other-modules:
         HelVM.HelCam.Common.FilterIf0Test
+        HelVM.HelCam.Common.RAMTest
 
         HelVM.HelCam.Machines.BrainFuck.TokensTest
         HelVM.HelCam.Machines.BrainFuck.Evaluator.InteractEvaluatorTest
         HelVM.HelCam.Machines.BrainFuck.Evaluator.MonadicEvaluatorTest
         HelVM.HelCam.Machines.BrainFuck.EvaluatorTest
         HelVM.HelCam.Machines.BrainFuck.EvaluatorTestData
 
+        HelVM.HelCam.Machines.ETA.Evaluator.InteractEvaluatorTest
         HelVM.HelCam.Machines.ETA.Evaluator.MonadicEvaluatorTest
+        HelVM.HelCam.Machines.ETA.EvaluatorTest
         HelVM.HelCam.Machines.ETA.EvaluatorTestData
         HelVM.HelCam.Machines.ETA.EvaluatorUtilTest
         HelVM.HelCam.Machines.ETA.LexerTest
@@ -111,6 +118,7 @@ test-suite helcam-test
   build-depends:
       base
     , relude               == 0.7.0.0
+    , containers           == 0.6.2.1
     , split
     , data-default
 
@@ -130,7 +138,9 @@ executable helcam
         HelVM.HelCam.Common.FilterIf0
         HelVM.HelCam.Common.MockIO
         HelVM.HelCam.Common.OrError
-        HelVM.HelCam.Common.Tape
+        HelVM.HelCam.Common.RAM.IntMapRAM
+        HelVM.HelCam.Common.RAM.ListRAM
+        HelVM.HelCam.Common.RAM.SeqRAM
         HelVM.HelCam.Common.Util
         HelVM.HelCam.Common.WrapperIO
 
@@ -153,8 +163,8 @@ executable helcam
         HelVM.HelCam.Machines.SubLeq.Evaluator
         HelVM.HelCam.Machines.SubLeq.Evaluator.InteractEvaluator
         HelVM.HelCam.Machines.SubLeq.Evaluator.MonadicEvaluator
-        HelVM.HelCam.Machines.SubLeq.EvaluatorUtil
         HelVM.HelCam.Machines.SubLeq.Lexer
+        HelVM.HelCam.Machines.SubLeq.Symbol
 
         HelVM.HelCam.Machines.WhiteSpace.Evaluator
         HelVM.HelCam.Machines.WhiteSpace.Evaluator.InteractEvaluator
@@ -169,6 +179,7 @@ executable helcam
   build-depends:
       base
     , relude               == 0.7.0.0
+    , containers           == 0.6.2.1
     , split
     , data-default
 

src/main/eta/HelVM/HelCam/Common/RAM/IntMapRAM.hs

@@ -0,0 +1,37 @@
+{-# Language GeneralizedNewtypeDeriving #-}
+module HelVM.HelCam.Common.RAM.IntMapRAM (
+  HelVM.HelCam.Common.RAM.IntMapRAM.RAM,
+  HelVM.HelCam.Common.RAM.IntMapRAM.empty,
+  HelVM.HelCam.Common.RAM.IntMapRAM.fromList,
+  load,
+  store
+) where
+
+import HelVM.HelCam.Common.Util
+
+import Data.Default
+import Data.IntMap as IntMap
+
+newtype RAM s = MakeRAM (IntMap s) deriving (Foldable)
+type DRAM s = D (RAM s)
+
+-- Constructors
+empty :: Default s => RAM s
+empty = MakeRAM IntMap.empty
+
+fromList :: Default s => [s] -> RAM s
+fromList list = MakeRAM $ IntMap.fromList $ zip [0..] list
+
+-- Mutators
+load :: (Integral a, Default s) => RAM s -> a -> s
+load (MakeRAM m) address = index' m (fromIntegral address) ?: def
+
+store :: (Integral a, Default s) => a -> s -> DRAM s
+store address symbol (MakeRAM m) = MakeRAM $ insert' (fromIntegral address) symbol m
+
+-- Private
+index' :: IntMap s -> Int -> Maybe s
+index' = (!?)
+
+insert' :: Int -> s -> IntMap s -> IntMap s
+insert' = insert

src/main/eta/HelVM/HelCam/Common/RAM/ListRAM.hs

@@ -0,0 +1,41 @@
+{-# Language GeneralizedNewtypeDeriving #-}
+module HelVM.HelCam.Common.RAM.ListRAM (
+  RAM,
+  empty,
+  fromList,
+  load,
+  store
+) where
+
+import HelVM.HelCam.Common.Util
+
+import Data.Default
+
+import Prelude hiding (empty, fromList)
+
+newtype RAM s = MakeRAM [s] deriving (Foldable)
+type DRAM s = D (RAM s)
+
+-- Constructors
+empty :: Default s => RAM s
+empty = MakeRAM []
+
+fromList :: Default s => [s] -> RAM s
+fromList = MakeRAM
+
+-- Mutators
+load :: (Integral a, Default s) => RAM s -> a -> s
+load (MakeRAM m) address = index' m (fromIntegral address) ?: def
+
+store :: (Integral a, Default s) => a -> s -> DRAM s
+store address symbol (MakeRAM m) = MakeRAM $ insert' (fromIntegral address) symbol m
+
+-- Private
+index' :: [s] -> Int -> Maybe s
+index' = (!!?)
+
+insert' :: Default s => Int -> s -> [s] -> [s]
+insert' 0       symbol []     = [symbol]
+insert' 0       symbol (_:xs) = symbol : xs
+insert' address symbol []     = def    : insert' (address-1) symbol []
+insert' address symbol (x:xs) = x      : insert' (address-1) symbol xs

src/main/eta/HelVM/HelCam/Common/RAM/SeqRAM.hs

@@ -0,0 +1,40 @@
+{-# Language GeneralizedNewtypeDeriving #-}
+module HelVM.HelCam.Common.RAM.SeqRAM (
+  RAM,
+  HelVM.HelCam.Common.RAM.SeqRAM.empty,
+  HelVM.HelCam.Common.RAM.SeqRAM.fromList,
+  load,
+  store
+) where
+
+import HelVM.HelCam.Common.Util
+
+import Data.Default
+import Data.Sequence as Seq
+
+newtype RAM s = MakeRAM (Seq s) deriving (Foldable)
+type DRAM s = D (RAM s)
+
+-- Constructors
+empty :: Default s => RAM s
+empty = MakeRAM Seq.empty
+
+fromList :: Default s => [s] -> RAM s
+fromList = MakeRAM . Seq.fromList
+
+-- Mutators
+load :: (Integral a, Default s) => RAM s -> a -> s
+load (MakeRAM m) address = index' m (fromIntegral address) ?: def
+
+store :: (Integral a, Default s) => a -> s -> DRAM s
+store address symbol (MakeRAM m) = MakeRAM $ insert' (fromIntegral address) symbol m
+
+-- Private
+index' :: Seq s -> Int -> Maybe s
+index' = (!?)
+
+insert' :: Default s => Int -> s -> Seq s -> Seq s
+insert' address symbol m = insert'' (Seq.length m) where
+  insert'' l
+    | address < l  = Seq.update address symbol m
+    | otherwise    = m <> Seq.replicate (address - l) def |> symbol

src/main/eta/HelVM/HelCam/Machines/BrainFuck/Evaluator.hs

@@ -29,8 +29,8 @@ class Evaluator r where
   doInstruction table@(_, Dec     :_) tape = doInstruction    (nextInst table)   (wPredSymbol tape)
   doInstruction table@(_, JmpPast :_) tape = doJmpPast                  table                 tape
   doInstruction table@(_, JmpBack :_) tape = doJmpBack                  table                 tape
-  doInstruction table@(_, Output  :_) tape = doOutput                   table                 tape
-  doInstruction table@(_, Input   :_) tape = doInput                    table                 tape
+  doInstruction table@(_, Output  :_) tape = doOutputChar               table                 tape
+  doInstruction table@(_, Input   :_) tape = doInputChar                table                 tape
   doInstruction       (_, []        ) _    = doEnd
 
   doJmpPast :: Symbol s => Table -> FullTape s -> r
@@ -41,9 +41,9 @@ class Evaluator r where
   doJmpBack table tape@(_, 0:_) = doInstruction (nextInst table) tape
   doJmpBack table tape          = doInstruction (jumpBack table) tape
 
-  doOutput  :: Symbol s => Table -> FullTape s -> r
-  doInput   :: Symbol s => Table -> FullTape s -> r
-  doEnd     :: r
+  doEnd        :: r
+  doOutputChar :: Symbol s => Table -> FullTape s -> r
+  doInputChar  :: Symbol s => Table -> FullTape s -> r
 
 ----
 
@@ -57,41 +57,41 @@ batchEvalWord8 :: Source -> Output
 batchEvalWord8  = flip evalWord8 ([]::String)
 
 instance Evaluator Interact where
-  doInput _     _          []     = error "Empty input"
-  doInput table tape (char:input) = doInstruction (nextInst table) (writeSymbol char tape) input
+  doEnd _ = []
 
-  doOutput _          (_, [])       _     = error "Illegal State"
-  doOutput table tape@(_, symbol:_) input = toChar symbol : doInstruction (nextInst table) tape input
+  doInputChar _     _          []     = error "Empty input"
+  doInputChar table tape (char:input) = doInstruction (nextInst table) (writeSymbol char tape) input
 
-  doEnd _ = []
+  doOutputChar _          (_, [])       _     = error "Illegal State"
+  doOutputChar table tape@(_, symbol:_) input = toChar symbol : doInstruction (nextInst table) tape input
 
 ----
 
 monadicEval :: Source -> IO ()
 monadicEval = evalWord8
 
 instance Evaluator (IO ()) where
-  doInput table tape = do
+  doEnd = pass
+
+  doInputChar table tape = do
     char <- IO.getChar
     doInstruction (nextInst table) (writeSymbol char tape)
 
-  doOutput _          (_, [])       = error "Illegal State"
-  doOutput table tape@(_, symbol:_) = do
+  doOutputChar _          (_, [])       = error "Illegal State"
+  doOutputChar table tape@(_, symbol:_) = do
     IO.putChar $ toChar symbol
     doInstruction (nextInst table) tape
 
-  doEnd = pass
-
 ----
 
 instance Evaluator (MockIO ()) where
-  doInput table tape = do
+  doEnd = pass
+
+  doInputChar table tape = do
     char <- mockGetChar
     doInstruction (nextInst table) (writeSymbol char tape)
 
-  doOutput _          (_, [])       = error "Illegal State"
-  doOutput table tape@(_, symbol:_) = do
+  doOutputChar _          (_, [])       = error "Illegal State"
+  doOutputChar table tape@(_, symbol:_) = do
     mockPutChar $ toChar symbol
     doInstruction (nextInst table) tape
-
-  doEnd = pass

src/main/eta/HelVM/HelCam/Machines/BrainFuck/Evaluator/InteractEvaluator.hs

@@ -35,8 +35,8 @@ doInstruction table@(_, Inc     :_) tape = doInstruction    (nextInst table)   (
 doInstruction table@(_, Dec     :_) tape = doInstruction    (nextInst table)   (wPredSymbol tape)
 doInstruction table@(_, JmpPast :_) tape = doJmpPast                  table                 tape
 doInstruction table@(_, JmpBack :_) tape = doJmpBack                  table                 tape
-doInstruction table@(_, Output  :_) tape = doOutput                   table                 tape
-doInstruction table@(_, Input   :_) tape = doInput                    table                 tape
+doInstruction table@(_, Output  :_) tape = doOutputChar                   table                 tape
+doInstruction table@(_, Input   :_) tape = doInputChar                    table                 tape
 doInstruction       (_, []        ) _    = doEnd
 
 doJmpPast :: Symbol s => Table -> FullTape s -> Interact
@@ -47,13 +47,14 @@ doJmpBack :: Symbol s => Table -> FullTape s -> Interact
 doJmpBack table tape@(_, 0:_) = doInstruction (nextInst table) tape
 doJmpBack table tape          = doInstruction (jumpBack table) tape
 
-doInput :: Symbol s => Table -> FullTape s -> Interact
-doInput _     _          []     = error "Empty input"
-doInput table tape (char:input) = doInstruction (nextInst table) (writeSymbol char tape) input
-
-doOutput :: Symbol s => Table -> FullTape s -> Interact
-doOutput _          (_, [])       _     = error "Illegal State"
-doOutput table tape@(_, symbol:_) input = toChar symbol : doInstruction (nextInst table) tape input
-
 doEnd :: Interact
 doEnd _ = []
+
+doInputChar :: Symbol s => Table -> FullTape s -> Interact
+doInputChar _     _          []     = error "Empty input"
+doInputChar table tape (char:input) = doInstruction (nextInst table) (writeSymbol char tape) input
+
+doOutputChar :: Symbol s => Table -> FullTape s -> Interact
+doOutputChar _          (_, [])       _     = error "Illegal State"
+doOutputChar table tape@(_, symbol:_) input = toChar symbol : doInstruction (nextInst table) tape input
+