{-# LANGUAGE GADTs #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ViewPatterns #-}

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

import Data.ByteString (ByteString)
import Data.Hash.Murmur (murmur3)
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, locToCoords)
import Swarm.Game.World.Gen (Seed)
import Swarm.Game.World.Syntax (Axis (..))
import Swarm.Game.World.Typecheck (Const (..), Empty (..), Over (..))
import Witch (from)
import Witch.Encoding qualified as Encoding

-- | 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) = Seed -> BTerm (a1 -> a) -> a1 -> a
forall a. Seed -> BTerm a -> a
interpBTerm Seed
seed BTerm (a1 -> a)
f (Seed -> BTerm a1 -> a1
forall a. Seed -> BTerm a -> a
interpBTerm Seed
seed BTerm a1
x)
interpBTerm Seed
seed (BConst Const a
c) = Seed -> Const a -> a
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 -> a
CellVal
c
  Const a
CIf -> \Bool
b a1
t a1
e -> if Bool
b then a1
t else a1
e
  Const a
CNot -> a
Bool -> Bool
not
  Const a
CNeg -> a
a1 -> a1
forall a. Num a => a -> a
negate
  Const a
CAbs -> a
a1 -> a1
forall a. Num a => a -> a
abs
  Const a
CAnd -> a
Bool -> Bool -> Bool
(&&)
  Const a
COr -> a
Bool -> Bool -> Bool
(||)
  Const a
CAdd -> a
a1 -> a1 -> a1
forall a. Num a => a -> a -> a
(+)
  Const a
CSub -> (-)
  Const a
CMul -> a
a1 -> a1 -> a1
forall a. Num a => a -> a -> a
(*)
  Const a
CDiv -> a
a1 -> a1 -> a1
forall a. Fractional a => a -> a -> a
(/)
  Const a
CIDiv -> a
a1 -> a1 -> a1
forall a. Integral a => a -> a -> a
div
  Const a
CMod -> a
a1 -> a1 -> a1
forall a. Integral a => a -> a -> a
mod
  Const a
CEq -> a
a1 -> a1 -> Bool
forall a. Eq a => a -> a -> Bool
(==)
  Const a
CNeq -> a
a1 -> a1 -> Bool
forall a. Eq a => a -> a -> Bool
(/=)
  Const a
CLt -> a
a1 -> a1 -> Bool
forall a. Ord a => a -> a -> Bool
(<)
  Const a
CLeq -> a
a1 -> a1 -> Bool
forall a. Ord a => a -> a -> Bool
(<=)
  Const a
CGt -> a
a1 -> a1 -> Bool
forall a. Ord a => a -> a -> Bool
(>)
  Const a
CGeq -> a
a1 -> a1 -> Bool
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 a1
forall e. Empty e => e
empty
  Const a
CSeed -> Seed -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral Seed
seed
  CCoord Axis
ax -> \(Coords -> Location
coordsToLoc -> Location Int32
x Int32
y) -> Int32 -> Integer
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) -> Word32 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Integer)
-> ((Int32, Int32) -> Word32) -> (Int32, Int32) -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> ByteString -> Word32
murmur3 (Seed -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Seed
seed) (ByteString -> Word32)
-> ((Int32, Int32) -> ByteString) -> (Int32, Int32) -> Word32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTF_8 ByteString -> ByteString
forall {k} (s :: k) b. Tagged s b -> b
unTagged (UTF_8 ByteString -> ByteString)
-> ((Int32, Int32) -> UTF_8 ByteString)
-> (Int32, Int32)
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall source target. From source target => source -> target
from @String @(Encoding.UTF_8 ByteString) (String -> UTF_8 ByteString)
-> ((Int32, Int32) -> String) -> (Int32, Int32) -> UTF_8 ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int32, Int32) -> String
forall a. Show a => a -> String
show ((Int32, Int32) -> Integer) -> (Int32, Int32) -> Integer
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 (Integer -> Seed
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
s) (Integer -> Seed
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) = Perlin -> Point -> Double
forall a. Noise a => a -> Point -> Double
noiseValue Perlin
noise (Int32 -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
i Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
2, Int32 -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
j Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
2, Double
0)
     in \(Coords (Int32, Int32)
ix) -> (Int32, Int32) -> Double
sample (Int32, Int32)
ix
  Const a
CFI -> a
Integer -> Double
forall a. Num a => Integer -> a
fromInteger
  Const a
COver -> a
a1 -> a1 -> a1
forall m. Over m => m -> m -> m
(<!>)
  Const a
CIMap -> \Coords -> Integer
wx Coords -> Integer
wy World a1
a Coords
c -> World a1
a (Location -> Coords
locToCoords (Int32 -> Int32 -> Location
Location (Integer -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Coords -> Integer
wx Coords
c)) (Integer -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Coords -> Integer
wy Coords
c))))
  Const a
K -> a
a1 -> b -> a1
forall a b. a -> b -> a
const
  Const a
S -> a
(a1 -> b -> c) -> (a1 -> b) -> a1 -> c
forall a b. (a1 -> a -> b) -> (a1 -> a) -> a1 -> b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
(<*>)
  Const a
I -> a
a1 -> a1
forall a. a -> a
id
  Const a
B -> a
(b -> c) -> (a1 -> b) -> a1 -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.)
  Const a
C -> a
(a1 -> b -> c) -> b -> a1 -> c
forall a b c. (a -> b -> c) -> b -> a -> c
flip
  Const a
Φ -> a
(a1 -> b -> c) -> (d -> a1) -> (d -> b) -> d -> c
forall a b c. (a -> b -> c) -> (d -> a) -> (d -> b) -> d -> c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2