Merge ArrayId into PrimitiveValue

app/elm/Environment.elm

@@ -1,5 +1,6 @@
 module Environment exposing
-    ( Environment
+    ( Arrays
+    , Environment
     , Object(..)
     , back
     , clean
@@ -39,14 +40,18 @@ type Object
     = Line Line
 
 
+type alias Arrays =
+    Dict Int { items : Array Type.Value, origin : Int, id : Maybe Int }
+
+
 type alias Environment =
     { history : History
     , objects : List ( Int, Object )
     , turtle : Turtle
     , penSize : Int
     , color : Color
     , nextId : Int
-    , arrays : Dict Int { items : Array Type.Value, origin : Int, id : Maybe Int }
+    , arrays : Arrays
     , nextArrayId : Int
     }
 

app/elm/Vm/Stack.elm

@@ -2,69 +2,51 @@ module Vm.Stack exposing
     ( PrimitiveValue(..)
     , Stack
     , Value(..)
-    , toTypeValue
     , toValue
     )
 
+import Dict
+import Environment exposing (Arrays)
 import Json.Encode as E
 import Vm.Type as Type
 
 
 {-| This module mainly holds the definition for a `Value` as it is represented
 on the stack.
-
-The introduction of arrays that are treated as references by UCBLogo poses a
-few challenges as the stack did not have to deal with reference values so far.
-This can be seen by the fact that there are now two different types,
-`PrimitiveValue` and `Value`, used to represent values on the stack. At this
-point, they are not clearly separated yet as `PrimitiveValue`, through its
-variant `List`, can hold arrays, and thus reference values. This also leads to
-certain programs’s behaviour diverging from their behaviour when run in
-UCBLogo.
-
-As of February 2024, I think a correct and simple solution would be to
-integrate `ArrayId` into `PrimitiveValue` and convert `PrimitiveValue` to
-`Type.Value` whenever a value is taken from the stack (and vice versa when it
-is put onto the stack). Since this would come at a performance cost, I’m
-slightly hesitant to adopt this solution.
-
 -}
 type PrimitiveValue
     = Word String
     | Int Int
     | Float Float
-    | List (List Type.Value)
+    | List (List PrimitiveValue)
+    | ArrayId Int
 
 
 type Value
     = Void
     | Address Int
     | Value PrimitiveValue
-    | ArrayId Int
 
 
 type alias Stack =
     List Value
 
 
-encodeValue : Value -> E.Value
-encodeValue value =
+encodeValue : Arrays -> Value -> E.Value
+encodeValue arrays value =
     case value of
         Void ->
             E.string "_"
 
         Address address ->
             E.string <| "@" ++ String.fromInt address
 
-        Value value_ ->
-            E.string <| Type.toDebugString <| toTypeValue value_
-
-        ArrayId id ->
-            E.string <| "array @" ++ String.fromInt id
+        Value primitive ->
+            E.string <| Type.toDebugString <| toTypeValue arrays primitive
 
 
-toTypeValue : PrimitiveValue -> Type.Value
-toTypeValue value =
+toTypeValue : Arrays -> PrimitiveValue -> Type.Value
+toTypeValue arrays value =
     case value of
         Word string ->
             Type.Word string
@@ -76,9 +58,14 @@ toTypeValue value =
             Type.Float float
 
         List list ->
-            Type.List list
+            Type.List (List.map (toTypeValue arrays) list)
+
+        ArrayId id ->
+            Dict.get id arrays
+                |> Maybe.map Type.Array
+                |> Maybe.withDefault (Type.Word "<array not found>")
 
 
-toValue : Stack -> E.Value
-toValue =
-    E.list encodeValue
+toValue : Arrays -> Stack -> E.Value
+toValue arrays =
+    E.list (encodeValue arrays)

app/elm/Vm/Vm.elm

@@ -216,7 +216,7 @@ toValue { instructions, programCounter, stack, scopes, environment } =
     E.object
         [ ( "instructions", encodeInstructions instructions )
         , ( "programCounter", E.int programCounter )
-        , ( "stack", Stack.toValue stack )
+        , ( "stack", Stack.toValue environment.arrays stack )
         , ( "scopes", E.list Scope.toValue scopes )
         , ( "environment", Environment.toValue environment )
         ]
@@ -229,23 +229,67 @@ incrementProgramCounter vm =
     { vm | programCounter = vm.programCounter + 1 }
 
 
-{-| Convert a `Type.Value` to a `Stack.Value`. If the value is a `Type.Array`,
-assign it an id and store it in the VM’s enviromnent.
+{-| Convert a `Stack.PrimitiveValue` to a `Type.Value`. If the value is a
+`Stack.ArrayId`, use the VM’s enviromnent to resolve it to an array.
 -}
-toStackValue : Type.Value -> Vm -> ( Stack.Value, Vm )
-toStackValue value vm =
+toTypeValue : Stack.PrimitiveValue -> Vm -> Result Error Type.Value
+toTypeValue value vm =
+    case value of
+        Stack.Word string ->
+            Ok <| Type.Word string
+
+        Stack.Int int ->
+            Ok <| Type.Int int
+
+        Stack.Float float ->
+            Ok <| Type.Float float
+
+        Stack.List list ->
+            let
+                list_ =
+                    List.foldl
+                        (\value_ acc -> Result.map2 (::) (toTypeValue value_ vm) acc)
+                        (Ok [])
+                        list
+            in
+            Result.map Type.List list_
+
+        Stack.ArrayId id ->
+            Dict.get id vm.environment.arrays
+                |> Result.fromMaybe (Internal ArrayNotFound)
+                |> Result.map Type.Array
+
+
+{-| Convert a `Type.Value` to a `Stack.PrimitiveValue`. If the value is a
+`Type.Array`, assign it an id and store it in the VM’s enviromnent.
+-}
+toStackPrimitiveValue : Type.Value -> Vm -> ( Stack.PrimitiveValue, Vm )
+toStackPrimitiveValue value vm =
     case value of
         Type.Word word ->
-            ( Stack.Value (Stack.Word word), vm )
+            ( Stack.Word word, vm )
 
         Type.Int int ->
-            ( Stack.Value (Stack.Int int), vm )
+            ( Stack.Int int, vm )
 
         Type.Float float ->
-            ( Stack.Value (Stack.Float float), vm )
+            ( Stack.Float float, vm )
 
         Type.List list ->
-            ( Stack.Value (Stack.List list), vm )
+            let
+                ( stackList, newVm ) =
+                    List.foldl
+                        (\value_ ( accList, accVm ) ->
+                            let
+                                ( stackValue, newAccVm ) =
+                                    toStackPrimitiveValue value_ accVm
+                            in
+                            ( stackValue :: accList, newAccVm )
+                        )
+                        ( [], vm )
+                        list
+            in
+            ( Stack.List stackList, newVm )
 
         Type.Array { items, origin, id } ->
             case id of
@@ -281,9 +325,9 @@ pushValue1 : Type.Value -> Vm -> Vm
 pushValue1 value vm =
     let
         ( newValue, newVm ) =
-            toStackValue value vm
+            toStackPrimitiveValue value vm
     in
-    { newVm | stack = newValue :: newVm.stack }
+    { newVm | stack = Stack.Value newValue :: newVm.stack }
 
 
 {-| Pop a single value from the stack. Return a value and the remaining stack.
@@ -295,15 +339,8 @@ popValue1 : Vm -> Result Error ( Type.Value, Vm )
 popValue1 vm =
     case vm.stack of
         (Stack.Value first) :: rest ->
-            Ok ( Stack.toTypeValue first, { vm | stack = rest } )
-
-        (Stack.ArrayId id) :: rest ->
-            case Dict.get id vm.environment.arrays of
-                Just array ->
-                    Ok ( Type.Array array, { vm | stack = rest } )
-
-                _ ->
-                    Err <| Internal ArrayNotFound
+            toTypeValue first vm
+                |> Result.map (\value -> ( value, { vm | stack = rest } ))
 
         _ ->
             Err <| Internal InvalidStack
@@ -390,12 +427,7 @@ popValues n vm =
                 (\value ->
                     case value of
                         Stack.Value value_ ->
-                            Ok (Stack.toTypeValue value_)
-
-                        Stack.ArrayId id ->
-                            Dict.get id vm.environment.arrays
-                                |> Result.fromMaybe (Internal ArrayNotFound)
-                                |> Result.map Type.Array
+                            toTypeValue value_ vm
 
                         _ ->
                             Err <| Internal InvalidStack

tests/Test/Encode.elm

@@ -6,6 +6,7 @@ module Test.Encode exposing
     , encodeAndDecodeVms
     )
 
+import Dict
 import Environment.History exposing (Entry(..))
 import Expect
 import Json.Decode as D
@@ -127,11 +128,11 @@ encodeAndDecodeStack =
                         [ Stack.Void
                         , Stack.Address 10
                         , Stack.Value <| Stack.Word "word"
-                        , Stack.Value <| Stack.List [ word, Type.List [ word ] ]
+                        , Stack.Value <| Stack.List [ Stack.Word "word", Stack.List [ Stack.Word "word" ] ]
                         ]
 
                     value =
-                        Stack.toValue stack
+                        Stack.toValue Dict.empty stack
                 in
                 D.decodeValue (D.list D.string) value
                     |> Expect.ok