{-# LANGUAGE GADTs #-}

-- |
-- SPDX-License-Identifier: BSD-3-Clause
--
-- Interpreter for the Swarm world description DSL.
module Swarm.Game.World.Interpret (
  interpBTerm,
  interpConst,
  interpReflect,
  interpRot,
) where

import Control.Applicative (Applicative (..))
import Data.ByteString (ByteString)
import Data.Hash.Murmur (murmur3)
import Data.Tagged (unTagged)
import Numeric.Noise.Perlin (noiseValue, perlin)
import Swarm.Game.World.Abstract (BTerm (..))
import Swarm.Game.World.Coords (Coords (..))
import Swarm.Game.World.Gen (Seed)
import Swarm.Game.World.Syntax (Axis (..), Rot (..))
import Swarm.Game.World.Typecheck (Const (..), Empty (..), Over (..))
import Witch (from)
import Witch.Encoding qualified as Encoding
import Prelude hiding (Applicative (..))

-- | Interpret an abstracted term into the host language.
interpBTerm :: Seed -> BTerm a -> a
interpBTerm :: forall a. Seed -> BTerm a -> a
interpBTerm Seed
seed (BApp BTerm (a1 -> a)
f BTerm a1
x) = forall a. Seed -> BTerm a -> a
interpBTerm Seed
seed BTerm (a1 -> a)
f (forall a. Seed -> BTerm a -> a
interpBTerm Seed
seed BTerm a1
x)
interpBTerm Seed
seed (BConst Const a
c) = forall a. Seed -> Const a -> a
interpConst Seed
seed Const a
c

-- | Interpret a constant into the host language.
interpConst :: Seed -> Const a -> a
interpConst :: forall a. Seed -> Const a -> a
interpConst Seed
seed = \case
  CLit a
a -> a
a
  CCell CellVal
c -> CellVal
c
  Const a
CIf -> \Bool
b a1
t a1
e -> if Bool
b then a1
t else a1
e
  Const a
CNot -> Bool -> Bool
not
  Const a
CNeg -> forall a. Num a => a -> a
negate
  Const a
CAbs -> forall a. Num a => a -> a
abs
  Const a
CAnd -> Bool -> Bool -> Bool
(&&)
  Const a
COr -> Bool -> Bool -> Bool
(||)
  Const a
CAdd -> forall a. Num a => a -> a -> a
(+)
  Const a
CSub -> (-)
  Const a
CMul -> forall a. Num a => a -> a -> a
(*)
  Const a
CDiv -> forall a. Fractional a => a -> a -> a
(/)
  Const a
CIDiv -> forall a. Integral a => a -> a -> a
div
  Const a
CMod -> forall a. Integral a => a -> a -> a
mod
  Const a
CEq -> forall a. Eq a => a -> a -> Bool
(==)
  Const a
CNeq -> forall a. Eq a => a -> a -> Bool
(/=)
  Const a
CLt -> forall a. Ord a => a -> a -> Bool
(<)
  Const a
CLeq -> forall a. Ord a => a -> a -> Bool
(<=)
  Const a
CGt -> forall a. Ord a => a -> a -> Bool
(>)
  Const a
CGeq -> forall a. Ord a => a -> a -> Bool
(>=)
  Const a
CMask -> \World Bool
b World a1
x Coords
c -> if World Bool
b Coords
c then World a1
x Coords
c else forall e. Empty e => e
empty
  Const a
CSeed -> forall a b. (Integral a, Num b) => a -> b
fromIntegral Seed
seed
  CCoord Axis
ax -> \(Coords (Int32
x, Int32
y)) -> forall a b. (Integral a, Num b) => a -> b
fromIntegral (case Axis
ax of Axis
X -> Int32
x; Axis
Y -> Int32
y)
  Const a
CHash -> \(Coords (Int32, Int32)
ix) -> forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> ByteString -> Word32
murmur3 Word32
0 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (s :: k) b. Tagged s b -> b
unTagged forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall source target. From source target => source -> target
from @String @(Encoding.UTF_8 ByteString) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ (Int32, Int32)
ix
  Const a
CPerlin -> \Integer
s Integer
o Double
k Double
p ->
    let noise :: Perlin
noise = Seed -> Seed -> Double -> Double -> Perlin
perlin (forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
s) (forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
o) Double
k Double
p
        sample :: (Int32, Int32) -> Double
sample (Int32
i, Int32
j) = forall a. Noise a => a -> Point -> Double
noiseValue Perlin
noise (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
i forall a. Fractional a => a -> a -> a
/ Double
2, forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
j forall a. Fractional a => a -> a -> a
/ Double
2, Double
0)
     in \(Coords (Int32, Int32)
ix) -> (Int32, Int32) -> Double
sample (Int32, Int32)
ix
  CReflect Axis
ax -> \World a1
w -> World a1
w forall b c a. (b -> c) -> (a -> b) -> a -> c
. Axis -> Coords -> Coords
interpReflect Axis
ax
  CRot Rot
r -> \World a1
w -> World a1
w forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rot -> Coords -> Coords
interpRot Rot
r
  Const a
CFI -> forall a. Num a => Integer -> a
fromInteger
  Const a
COver -> forall m. Over m => m -> m -> m
(<!>)
  Const a
K -> forall a b. a -> b -> a
const
  Const a
S -> forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
(<*>)
  Const a
I -> forall a. a -> a
id
  Const a
B -> forall b c a. (b -> c) -> (a -> b) -> a -> c
(.)
  Const a
C -> forall a b c. (a -> b -> c) -> b -> a -> c
flip
  Const a
Φ -> forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2

-- | Interprect a reflection.
interpReflect :: Axis -> Coords -> Coords
interpReflect :: Axis -> Coords -> Coords
interpReflect Axis
ax (Coords (Int32
r, Int32
c)) = (Int32, Int32) -> Coords
Coords (case Axis
ax of Axis
X -> (Int32
r, -Int32
c); Axis
Y -> (-Int32
r, Int32
c))

-- | Interpret a rotation.
interpRot :: Rot -> Coords -> Coords
interpRot :: Rot -> Coords -> Coords
interpRot Rot
rot (Coords (Int32, Int32)
crd) = (Int32, Int32) -> Coords
Coords (Rot -> (Int32, Int32) -> (Int32, Int32)
rotTuple Rot
rot (Int32, Int32)
crd)
 where
  rotTuple :: Rot -> (Int32, Int32) -> (Int32, Int32)
rotTuple = \case
    Rot
Rot0 -> forall a. a -> a
id
    Rot
Rot90 -> \(Int32
r, Int32
c) -> (-Int32
c, Int32
r)
    Rot
Rot180 -> \(Int32
r, Int32
c) -> (-Int32
r, -Int32
c)
    Rot
Rot270 -> \(Int32
r, Int32
c) -> (Int32
c, -Int32
r)