Add imap primitive to world DSL, and remove rot and reflect

data/scenarios/Testing/1320-world-DSL/00-ORDER.txt

@@ -2,3 +2,4 @@ constant.yaml
 erase.yaml
 override.yaml
 coords.yaml
+reflect.yaml

data/scenarios/Testing/1320-world-DSL/reflect.yaml

@@ -0,0 +1,46 @@
+version: 1
+name: Reflection (imap) test
+description: |
+  A world with both horizontal and vertical reflection symmetry,
+  created with 'imap'.
+creative: false
+objectives:
+  - goal:
+      - Pick up four trees
+    condition: |
+      as base {n <- count "tree"; return (n >= 4)}
+robots:
+  - name: base
+    loc: [0, 0]
+    dir: north
+    devices:
+      - logger
+      - grabber
+      - treads
+      - branch predictor
+      - scanner
+      - ADT calculator
+      - comparator
+      - GPS receiver
+      - bitcoin
+solution: |
+  def x = \n. \c. if (n==0) {} {c; x (n-1) c} end
+  def ifC = \p. \t. \e. b <- p; if b t e end
+  def findTree = ifC (ishere "tree") {whereami} {move; findTree} end
+  def ell = \d. turn right; x (2*d) move; grab; return () end
+  def grabTrees = \loc. let x = fst loc in let y = snd loc in grab; ell y; ell x; ell y end
+  n <- random 10;
+  x (n+1) move; turn right; move;
+  loc <- findTree;
+  grabTrees loc
+known: [tree]
+world:
+  dsl: |
+    let trees = if (hash % 4 == 0) then {tree, dirt} else {stone}
+    in
+      overlay
+      [ mask (x >= 0 && y >= 0) trees
+      , mask (x >= 0 && y < 0) (imap x (-y) trees)
+      , mask (x < 0 && y >= 0) (imap (-x) y trees)
+      , mask (x < 0 && y < 0) (imap (-x) (-y) trees)
+      ]

src/swarm-scenario/Swarm/Game/World/Compile.hs

@@ -24,10 +24,9 @@ import Data.Tagged (Tagged (unTagged))
 import Numeric.Noise.Perlin (noiseValue, perlin)
 import Swarm.Game.Location (pattern Location)
 import Swarm.Game.World.Abstract (BTerm (..))
-import Swarm.Game.World.Coords (Coords (..), coordsToLoc)
+import Swarm.Game.World.Coords (Coords (..), coordsToLoc, locToCoords)
 import Swarm.Game.World.Gen (Seed)
-import Swarm.Game.World.Interpret (interpReflect, interpRot)
-import Swarm.Game.World.Syntax (Axis (..), Rot, World)
+import Swarm.Game.World.Syntax (Axis (..), World)
 import Swarm.Game.World.Typecheck (Applicable (..), Const (..), Empty (..), NotFun, Over (..))
 import Witch (from)
 import Witch.Encoding qualified as Encoding
@@ -71,9 +70,8 @@ compileConst seed = \case
   CCoord ax -> CFun $ \(CConst (coordsToLoc -> Location x y)) -> CConst (fromIntegral (case ax of X -> x; Y -> y))
   CHash -> compileHash seed
   CPerlin -> compilePerlin
-  CReflect ax -> compileReflect ax
-  CRot rot -> compileRot rot
   COver -> binary (<!>)
+  CIMap -> compileIMap
   K -> CFun $ \x -> CFun $ const x
   S -> CFun $ \f -> CFun $ \g -> CFun $ \x -> f $$ x $$ (g $$ x)
   I -> CFun id
@@ -110,11 +108,15 @@ compilePerlin =
  where
   sample (i, j) noise = noiseValue noise (fromIntegral i / 2, fromIntegral j / 2, 0)
 
-compileReflect :: Axis -> CTerm (World a -> World a)
-compileReflect ax = CFun $ \w -> CFun $ \(CConst c) -> w $$ CConst (interpReflect ax c)
-
-compileRot :: Rot -> CTerm (World a -> World a)
-compileRot rot = CFun $ \w -> CFun $ \(CConst c) -> w $$ CConst (interpRot rot c)
+compileIMap :: NotFun a => CTerm (World Integer -> World Integer -> World a -> World a)
+compileIMap =
+  CFun $ \wx ->
+    CFun $ \wy ->
+      CFun $ \wa ->
+        CFun $ \c ->
+          let mkCoords :: CTerm Integer -> CTerm Integer -> CTerm Coords
+              mkCoords (CConst x) (CConst y) = CConst (locToCoords (Location (fromIntegral x) (fromIntegral y)))
+           in wa $$ mkCoords (wx $$ c) (wy $$ c)
 
 type family NoFunParams a :: Constraint where
   NoFunParams (a -> b) = (NotFun a, NoFunParams b)

src/swarm-scenario/Swarm/Game/World/Interpret.hs

@@ -9,8 +9,6 @@
 module Swarm.Game.World.Interpret (
   interpBTerm,
   interpConst,
-  interpReflect,
-  interpRot,
 ) where
 
 import Control.Applicative (Applicative (..))
@@ -20,9 +18,9 @@ import Data.Tagged (unTagged)
 import Numeric.Noise.Perlin (noiseValue, perlin)
 import Swarm.Game.Location (pattern Location)
 import Swarm.Game.World.Abstract (BTerm (..))
-import Swarm.Game.World.Coords (Coords (..), coordsToLoc)
+import Swarm.Game.World.Coords (Coords (..), coordsToLoc, locToCoords)
 import Swarm.Game.World.Gen (Seed)
-import Swarm.Game.World.Syntax (Axis (..), Rot (..))
+import Swarm.Game.World.Syntax (Axis (..))
 import Swarm.Game.World.Typecheck (Const (..), Empty (..), Over (..))
 import Witch (from)
 import Witch.Encoding qualified as Encoding
@@ -64,27 +62,12 @@ interpConst seed = \case
     let noise = perlin (fromIntegral s) (fromIntegral o) k p
         sample (i, j) = noiseValue noise (fromIntegral i / 2, fromIntegral j / 2, 0)
      in \(Coords ix) -> sample ix
-  CReflect ax -> \w -> w . interpReflect ax
-  CRot r -> \w -> w . interpRot r
   CFI -> fromInteger
   COver -> (<!>)
+  CIMap -> \wx wy a c -> a (locToCoords (Location (fromIntegral (wx c)) (fromIntegral (wy c))))
   K -> const
   S -> (<*>)
   I -> id
   B -> (.)
   C -> flip
   Φ -> liftA2
-
--- | Interprect a reflection.
-interpReflect :: Axis -> Coords -> Coords
-interpReflect ax (Coords (r, c)) = Coords (case ax of X -> (r, -c); Y -> (-r, c))
-
--- | Interpret a rotation.
-interpRot :: Rot -> Coords -> Coords
-interpRot rot (Coords crd) = Coords (rotTuple rot crd)
- where
-  rotTuple = \case
-    Rot0 -> id
-    Rot90 -> \(r, c) -> (-c, r)
-    Rot180 -> \(r, c) -> (-r, -c)
-    Rot270 -> \(r, c) -> (c, -r)

src/swarm-scenario/Swarm/Game/World/Parse.hs

@@ -52,6 +52,7 @@ reservedWords =
   , "mask"
   , "empty"
   , "abs"
+  , "imap"
   ]
 
 -- | Skip spaces and comments.
@@ -139,6 +140,7 @@ parseWExpAtom =
     <|> parseOverlay
     <|> parseMask
     <|> parseImport
+    <|> parseIMap
     -- <|> parseCat
     -- <|> parseStruct
     <|> parens parseWExp
@@ -238,6 +240,14 @@ parseMask = do
 parseImport :: Parser WExp
 parseImport = WImport . into @Text <$> between (symbol "\"") (symbol "\"") (some (satisfy (/= '"')))
 
+parseIMap :: Parser WExp
+parseIMap = do
+  reserved "imap"
+  wx <- parseWExpAtom
+  wy <- parseWExpAtom
+  wa <- parseWExpAtom
+  return $ WOp IMap [wx, wy, wa]
+
 -- parseCat :: Parser WExp
 -- parseCat =
 --   WCat

src/swarm-scenario/Swarm/Game/World/Syntax.hs

@@ -10,7 +10,6 @@ module Swarm.Game.World.Syntax (
   RawCellVal,
   CellTag (..),
   CellVal (..),
-  Rot (..),
   Var,
   Axis (..),
   Op (..),
@@ -65,16 +64,6 @@ instance PrettyPrec CellVal where
         ++ [(Just CellEntity, e ^. entityName) | EJust (Last e) <- [ent]]
         ++ map ((Just CellRobot,) . view trobotName) rs
 
-data Rot = Rot0 | Rot90 | Rot180 | Rot270
-  deriving (Eq, Ord, Show, Bounded, Enum)
-
-instance PrettyPrec Rot where
-  prettyPrec _ = \case
-    Rot0 -> "rot0"
-    Rot90 -> "rot90"
-    Rot180 -> "rot180"
-    Rot270 -> "rot270"
-
 type Var = Text
 
 data Axis = X | Y
@@ -83,7 +72,7 @@ data Axis = X | Y
 instance PrettyPrec Axis where
   prettyPrec _ = \case X -> "x"; Y -> "y"
 
-data Op = Not | Neg | And | Or | Add | Sub | Mul | Div | Mod | Eq | Neq | Lt | Leq | Gt | Geq | If | Perlin | Reflect Axis | Rot Rot | Mask | Overlay | Abs
+data Op = Not | Neg | And | Or | Add | Sub | Mul | Div | Mod | Eq | Neq | Lt | Leq | Gt | Geq | If | Perlin | Mask | Overlay | Abs | IMap
   deriving (Eq, Ord, Show)
 
 ------------------------------------------------------------

src/swarm-scenario/Swarm/Game/World/Typecheck.hs

@@ -127,9 +127,8 @@ data Const :: Type -> Type where
   CCoord :: Axis -> Const (World Integer)
   CHash :: Const (World Integer)
   CPerlin :: Const (Integer -> Integer -> Double -> Double -> World Double)
-  CReflect :: Axis -> Const (World a -> World a)
-  CRot :: Rot -> Const (World a -> World a)
   COver :: (Over a, NotFun a) => Const (a -> a -> a)
+  CIMap :: NotFun a => Const (World Integer -> World Integer -> World a -> World a)
   -- Combinators generated during elaboration + variable abstraction
   K :: Const (a -> b -> a)
   S :: Const ((a -> b -> c) -> (a -> b) -> a -> c)
@@ -186,9 +185,8 @@ instance PrettyPrec (Const α) where
     CCoord ax -> ppr ax
     CHash -> "hash"
     CPerlin -> "perlin"
-    CReflect ax -> case ax of X -> "vreflect"; Y -> "hreflect"
-    CRot rot -> ppr rot
     COver -> "over"
+    CIMap -> "imap"
     K -> "K"
     S -> "S"
     I -> "I"
@@ -403,6 +401,13 @@ checkOver (TTyBase BFloat) a = a
 checkOver (TTyBase BCell) a = a
 checkOver ty _ = throwError $ NoInstance "Over" ty
 
+checkNotFun :: (Has (Throw CheckErr) sig m) => TTy ty -> (NotFun ty => m a) -> m a
+checkNotFun (TTyBase BBool) a = a
+checkNotFun (TTyBase BInt) a = a
+checkNotFun (TTyBase BFloat) a = a
+checkNotFun (TTyBase BCell) a = a
+checkNotFun ty _ = throwError $ NoInstance "NotFun" ty
+
 ------------------------------------------------------------
 -- Existential wrappers
 
@@ -532,10 +537,9 @@ inferOp [SomeTy tyA] Gt = Some (tyA :->: tyA :->: TTyBool) <$> checkOrd tyA (ret
 inferOp [SomeTy tyA] Geq = Some (tyA :->: tyA :->: TTyBool) <$> checkOrd tyA (return $ embed CGeq)
 inferOp [SomeTy tyA] If = return $ Some (TTyBool :->: tyA :->: tyA :->: tyA) (embed CIf)
 inferOp _ Perlin = return $ Some (TTyInt :->: TTyInt :->: TTyFloat :->: TTyFloat :->: TTyWorld TTyFloat) (embed CPerlin)
-inferOp [SomeTy tyA] (Reflect r) = return $ Some (TTyWorld tyA :->: TTyWorld tyA) (embed (CReflect r))
-inferOp [SomeTy tyA] (Rot r) = return $ Some (TTyWorld tyA :->: TTyWorld tyA) (embed (CRot r))
 inferOp [SomeTy tyA] Mask = Some (TTyWorld TTyBool :->: TTyWorld tyA :->: TTyWorld tyA) <$> checkEmpty tyA (return $ embed CMask)
 inferOp [SomeTy tyA] Overlay = Some (tyA :->: tyA :->: tyA) <$> checkOver tyA (return $ embed COver)
+inferOp [SomeTy tyA] IMap = Some (TTyWorld TTyInt :->: TTyWorld TTyInt :->: TTyWorld tyA :->: TTyWorld tyA) <$> checkNotFun tyA (return $ embed CIMap)
 inferOp tys op = error $ "bad call to inferOp: " ++ show tys ++ " " ++ show op
 
 -- | Given a raw operator and the terms the operator is applied to,
@@ -553,10 +557,9 @@ inferOp tys op = error $ "bad call to inferOp: " ++ show tys ++ " " ++ show op
 typeArgsFor :: Op -> [Some (TTerm g)] -> [SomeTy]
 typeArgsFor op (t : _)
   | op `elem` [Neg, Abs, Add, Sub, Mul, Div, Mod, Eq, Neq, Lt, Leq, Gt, Geq] = [getBaseType t]
-typeArgsFor (Reflect _) (t : _) = [getBaseType t]
-typeArgsFor (Rot _) (t : _) = [getBaseType t]
 typeArgsFor op (_ : t : _)
   | op `elem` [If, Mask, Overlay] = [getBaseType t]
+typeArgsFor IMap (_ : _ : t : _) = [getBaseType t]
 typeArgsFor _ _ = []
 
 -- | Typecheck the application of an operator to some terms, returning