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

-- |
-- SPDX-License-Identifier: BSD-3-Clause
--
-- Compiling abstracted combinator expressions ('BTerm') to native
-- Haskell terms.  This can supposedly be more efficient than directly
-- interpreting 'BTerm's, but some benchmarking is probably needed to
-- decide whether we want this or not.
--
-- For more info, see:
--
--   https://byorgey.wordpress.com/2023/07/13/compiling-to-intrinsically-typed-combinators/
module Swarm.Game.World.Compile where

import Data.ByteString (ByteString)
import Data.Hash.Murmur (murmur3)
import Data.Kind (Constraint)
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, locToCoords)
import Swarm.Game.World.Gen (Seed)
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

data CTerm a where
  CFun :: (CTerm a -> CTerm b) -> CTerm (a -> b)
  CConst :: (NotFun a) => a -> CTerm a

instance Applicable CTerm where
  CFun CTerm a -> CTerm b
f $$ :: forall a b. CTerm (a -> b) -> CTerm a -> CTerm b
$$ CTerm a
x = CTerm a -> CTerm b
f CTerm a
CTerm a
x

compile :: Seed -> BTerm a -> CTerm a
compile :: forall a. Seed -> BTerm a -> CTerm a
compile Seed
seed (BApp BTerm (a1 -> a)
b1 BTerm a1
b2) = Seed -> BTerm (a1 -> a) -> CTerm (a1 -> a)
forall a. Seed -> BTerm a -> CTerm a
compile Seed
seed BTerm (a1 -> a)
b1 CTerm (a1 -> a) -> CTerm a1 -> CTerm a
forall a b. CTerm (a -> b) -> CTerm a -> CTerm b
forall (t :: * -> *) a b. Applicable t => t (a -> b) -> t a -> t b
$$ Seed -> BTerm a1 -> CTerm a1
forall a. Seed -> BTerm a -> CTerm a
compile Seed
seed BTerm a1
b2
compile Seed
seed (BConst Const a
c) = Seed -> Const a -> CTerm a
forall a. Seed -> Const a -> CTerm a
compileConst Seed
seed Const a
c

compileConst :: Seed -> Const a -> CTerm a
compileConst :: forall a. Seed -> Const a -> CTerm a
compileConst Seed
seed = \case
  CLit a
i -> a -> CTerm a
forall a. NotFun a => a -> CTerm a
CConst a
i
  CCell CellVal
c -> a -> CTerm a
forall a. NotFun a => a -> CTerm a
CConst a
CellVal
c
  Const a
CFI -> (Integer -> Double) -> CTerm (Integer -> Double)
forall a b. (NotFun a, NotFun b) => (a -> b) -> CTerm (a -> b)
unary Integer -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral
  Const a
CIf -> (CTerm Bool -> CTerm (a1 -> a1 -> a1))
-> CTerm (Bool -> a1 -> a1 -> a1)
forall a b. (CTerm a -> CTerm b) -> CTerm (a -> b)
CFun ((CTerm Bool -> CTerm (a1 -> a1 -> a1))
 -> CTerm (Bool -> a1 -> a1 -> a1))
-> (CTerm Bool -> CTerm (a1 -> a1 -> a1))
-> CTerm (Bool -> a1 -> a1 -> a1)
forall a b. (a -> b) -> a -> b
$ \(CConst Bool
b) -> (CTerm a1 -> CTerm (a1 -> a1)) -> CTerm (a1 -> a1 -> a1)
forall a b. (CTerm a -> CTerm b) -> CTerm (a -> b)
CFun ((CTerm a1 -> CTerm (a1 -> a1)) -> CTerm (a1 -> a1 -> a1))
-> (CTerm a1 -> CTerm (a1 -> a1)) -> CTerm (a1 -> a1 -> a1)
forall a b. (a -> b) -> a -> b
$ \CTerm a1
t -> (CTerm a1 -> CTerm a1) -> CTerm (a1 -> a1)
forall a b. (CTerm a -> CTerm b) -> CTerm (a -> b)
CFun ((CTerm a1 -> CTerm a1) -> CTerm (a1 -> a1))
-> (CTerm a1 -> CTerm a1) -> CTerm (a1 -> a1)
forall a b. (a -> b) -> a -> b
$ \CTerm a1
e -> if Bool
b then CTerm a1
t else CTerm a1
e
  Const a
CNot -> (Bool -> Bool) -> CTerm (Bool -> Bool)
forall a b. (NotFun a, NotFun b) => (a -> b) -> CTerm (a -> b)
unary Bool -> Bool
not
  Const a
CNeg -> (a1 -> a1) -> CTerm (a1 -> a1)
forall a b. (NotFun a, NotFun b) => (a -> b) -> CTerm (a -> b)
unary a1 -> a1
forall a. Num a => a -> a
negate
  Const a
CAbs -> (a1 -> a1) -> CTerm (a1 -> a1)
forall a b. (NotFun a, NotFun b) => (a -> b) -> CTerm (a -> b)
unary a1 -> a1
forall a. Num a => a -> a
abs
  Const a
CAnd -> (Bool -> Bool -> Bool) -> CTerm (Bool -> Bool -> Bool)
forall a b c.
(NotFun a, NotFun b, NotFun c) =>
(a -> b -> c) -> CTerm (a -> b -> c)
binary Bool -> Bool -> Bool
(&&)
  Const a
COr -> (Bool -> Bool -> Bool) -> CTerm (Bool -> Bool -> Bool)
forall a b c.
(NotFun a, NotFun b, NotFun c) =>
(a -> b -> c) -> CTerm (a -> b -> c)
binary Bool -> Bool -> Bool
(||)
  Const a
CAdd -> (a1 -> a1 -> a1) -> CTerm (a1 -> a1 -> a1)
forall a b c.
(NotFun a, NotFun b, NotFun c) =>
(a -> b -> c) -> CTerm (a -> b -> c)
binary a1 -> a1 -> a1
forall a. Num a => a -> a -> a
(+)
  Const a
CSub -> (a1 -> a1 -> a1) -> CTerm (a1 -> a1 -> a1)
forall a b c.
(NotFun a, NotFun b, NotFun c) =>
(a -> b -> c) -> CTerm (a -> b -> c)
binary (-)
  Const a
CMul -> (a1 -> a1 -> a1) -> CTerm (a1 -> a1 -> a1)
forall a b c.
(NotFun a, NotFun b, NotFun c) =>
(a -> b -> c) -> CTerm (a -> b -> c)
binary a1 -> a1 -> a1
forall a. Num a => a -> a -> a
(*)
  Const a
CDiv -> (a1 -> a1 -> a1) -> CTerm (a1 -> a1 -> a1)
forall a b c.
(NotFun a, NotFun b, NotFun c) =>
(a -> b -> c) -> CTerm (a -> b -> c)
binary a1 -> a1 -> a1
forall a. Fractional a => a -> a -> a
(/)
  Const a
CIDiv -> (a1 -> a1 -> a1) -> CTerm (a1 -> a1 -> a1)
forall a b c.
(NotFun a, NotFun b, NotFun c) =>
(a -> b -> c) -> CTerm (a -> b -> c)
binary a1 -> a1 -> a1
forall a. Integral a => a -> a -> a
div
  Const a
CMod -> (a1 -> a1 -> a1) -> CTerm (a1 -> a1 -> a1)
forall a b c.
(NotFun a, NotFun b, NotFun c) =>
(a -> b -> c) -> CTerm (a -> b -> c)
binary a1 -> a1 -> a1
forall a. Integral a => a -> a -> a
mod
  Const a
CEq -> (a1 -> a1 -> Bool) -> CTerm (a1 -> a1 -> Bool)
forall a b c.
(NotFun a, NotFun b, NotFun c) =>
(a -> b -> c) -> CTerm (a -> b -> c)
binary a1 -> a1 -> Bool
forall a. Eq a => a -> a -> Bool
(==)
  Const a
CNeq -> (a1 -> a1 -> Bool) -> CTerm (a1 -> a1 -> Bool)
forall a b c.
(NotFun a, NotFun b, NotFun c) =>
(a -> b -> c) -> CTerm (a -> b -> c)
binary a1 -> a1 -> Bool
forall a. Eq a => a -> a -> Bool
(/=)
  Const a
CLt -> (a1 -> a1 -> Bool) -> CTerm (a1 -> a1 -> Bool)
forall a b c.
(NotFun a, NotFun b, NotFun c) =>
(a -> b -> c) -> CTerm (a -> b -> c)
binary a1 -> a1 -> Bool
forall a. Ord a => a -> a -> Bool
(<)
  Const a
CLeq -> (a1 -> a1 -> Bool) -> CTerm (a1 -> a1 -> Bool)
forall a b c.
(NotFun a, NotFun b, NotFun c) =>
(a -> b -> c) -> CTerm (a -> b -> c)
binary a1 -> a1 -> Bool
forall a. Ord a => a -> a -> Bool
(<=)
  Const a
CGt -> (a1 -> a1 -> Bool) -> CTerm (a1 -> a1 -> Bool)
forall a b c.
(NotFun a, NotFun b, NotFun c) =>
(a -> b -> c) -> CTerm (a -> b -> c)
binary a1 -> a1 -> Bool
forall a. Ord a => a -> a -> Bool
(>)
  Const a
CGeq -> (a1 -> a1 -> Bool) -> CTerm (a1 -> a1 -> Bool)
forall a b c.
(NotFun a, NotFun b, NotFun c) =>
(a -> b -> c) -> CTerm (a -> b -> c)
binary a1 -> a1 -> Bool
forall a. Ord a => a -> a -> Bool
(>=)
  Const a
CMask -> CTerm a
CTerm (World Bool -> World a1 -> World a1)
forall a.
(NotFun a, Empty a) =>
CTerm (World Bool -> World a -> World a)
compileMask
  Const a
CSeed -> a -> CTerm a
forall a. NotFun a => a -> CTerm a
CConst (Seed -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral Seed
seed)
  CCoord Axis
ax -> (CTerm Coords -> CTerm Integer) -> CTerm (Coords -> Integer)
forall a b. (CTerm a -> CTerm b) -> CTerm (a -> b)
CFun ((CTerm Coords -> CTerm Integer) -> CTerm (Coords -> Integer))
-> (CTerm Coords -> CTerm Integer) -> CTerm (Coords -> Integer)
forall a b. (a -> b) -> a -> b
$ \(CConst (Coords -> Location
coordsToLoc -> Location Int32
x Int32
y)) -> Integer -> CTerm Integer
forall a. NotFun a => a -> CTerm a
CConst (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 -> Seed -> CTerm (Coords -> Integer)
compileHash Seed
seed
  Const a
CPerlin -> CTerm a
CTerm (Integer -> Integer -> Double -> Double -> World Double)
compilePerlin
  Const a
COver -> (a1 -> a1 -> a1) -> CTerm (a1 -> a1 -> a1)
forall a b c.
(NotFun a, NotFun b, NotFun c) =>
(a -> b -> c) -> CTerm (a -> b -> c)
binary a1 -> a1 -> a1
forall m. Over m => m -> m -> m
(<!>)
  Const a
CIMap -> CTerm a
CTerm
  ((Coords -> Integer)
   -> (Coords -> Integer) -> World a1 -> World a1)
forall a.
NotFun a =>
CTerm
  ((Coords -> Integer) -> (Coords -> Integer) -> World a -> World a)
compileIMap
  Const a
K -> (CTerm a1 -> CTerm (b -> a1)) -> CTerm (a1 -> b -> a1)
forall a b. (CTerm a -> CTerm b) -> CTerm (a -> b)
CFun ((CTerm a1 -> CTerm (b -> a1)) -> CTerm (a1 -> b -> a1))
-> (CTerm a1 -> CTerm (b -> a1)) -> CTerm (a1 -> b -> a1)
forall a b. (a -> b) -> a -> b
$ \CTerm a1
x -> (CTerm b -> CTerm a1) -> CTerm (b -> a1)
forall a b. (CTerm a -> CTerm b) -> CTerm (a -> b)
CFun ((CTerm b -> CTerm a1) -> CTerm (b -> a1))
-> (CTerm b -> CTerm a1) -> CTerm (b -> a1)
forall a b. (a -> b) -> a -> b
$ CTerm a1 -> CTerm b -> CTerm a1
forall a b. a -> b -> a
const CTerm a1
x
  Const a
S -> (CTerm (a1 -> b -> c) -> CTerm ((a1 -> b) -> a1 -> c))
-> CTerm ((a1 -> b -> c) -> (a1 -> b) -> a1 -> c)
forall a b. (CTerm a -> CTerm b) -> CTerm (a -> b)
CFun ((CTerm (a1 -> b -> c) -> CTerm ((a1 -> b) -> a1 -> c))
 -> CTerm ((a1 -> b -> c) -> (a1 -> b) -> a1 -> c))
-> (CTerm (a1 -> b -> c) -> CTerm ((a1 -> b) -> a1 -> c))
-> CTerm ((a1 -> b -> c) -> (a1 -> b) -> a1 -> c)
forall a b. (a -> b) -> a -> b
$ \CTerm (a1 -> b -> c)
f -> (CTerm (a1 -> b) -> CTerm (a1 -> c))
-> CTerm ((a1 -> b) -> a1 -> c)
forall a b. (CTerm a -> CTerm b) -> CTerm (a -> b)
CFun ((CTerm (a1 -> b) -> CTerm (a1 -> c))
 -> CTerm ((a1 -> b) -> a1 -> c))
-> (CTerm (a1 -> b) -> CTerm (a1 -> c))
-> CTerm ((a1 -> b) -> a1 -> c)
forall a b. (a -> b) -> a -> b
$ \CTerm (a1 -> b)
g -> (CTerm a1 -> CTerm c) -> CTerm (a1 -> c)
forall a b. (CTerm a -> CTerm b) -> CTerm (a -> b)
CFun ((CTerm a1 -> CTerm c) -> CTerm (a1 -> c))
-> (CTerm a1 -> CTerm c) -> CTerm (a1 -> c)
forall a b. (a -> b) -> a -> b
$ \CTerm a1
x -> CTerm (a1 -> b -> c)
f CTerm (a1 -> b -> c) -> CTerm a1 -> CTerm (b -> c)
forall a b. CTerm (a -> b) -> CTerm a -> CTerm b
forall (t :: * -> *) a b. Applicable t => t (a -> b) -> t a -> t b
$$ CTerm a1
x CTerm (b -> c) -> CTerm b -> CTerm c
forall a b. CTerm (a -> b) -> CTerm a -> CTerm b
forall (t :: * -> *) a b. Applicable t => t (a -> b) -> t a -> t b
$$ (CTerm (a1 -> b)
g CTerm (a1 -> b) -> CTerm a1 -> CTerm b
forall a b. CTerm (a -> b) -> CTerm a -> CTerm b
forall (t :: * -> *) a b. Applicable t => t (a -> b) -> t a -> t b
$$ CTerm a1
x)
  Const a
I -> (CTerm a1 -> CTerm a1) -> CTerm (a1 -> a1)
forall a b. (CTerm a -> CTerm b) -> CTerm (a -> b)
CFun CTerm a1 -> CTerm a1
forall a. a -> a
id
  Const a
B -> (CTerm (b -> c) -> CTerm ((a1 -> b) -> a1 -> c))
-> CTerm ((b -> c) -> (a1 -> b) -> a1 -> c)
forall a b. (CTerm a -> CTerm b) -> CTerm (a -> b)
CFun ((CTerm (b -> c) -> CTerm ((a1 -> b) -> a1 -> c))
 -> CTerm ((b -> c) -> (a1 -> b) -> a1 -> c))
-> (CTerm (b -> c) -> CTerm ((a1 -> b) -> a1 -> c))
-> CTerm ((b -> c) -> (a1 -> b) -> a1 -> c)
forall a b. (a -> b) -> a -> b
$ \CTerm (b -> c)
f -> (CTerm (a1 -> b) -> CTerm (a1 -> c))
-> CTerm ((a1 -> b) -> a1 -> c)
forall a b. (CTerm a -> CTerm b) -> CTerm (a -> b)
CFun ((CTerm (a1 -> b) -> CTerm (a1 -> c))
 -> CTerm ((a1 -> b) -> a1 -> c))
-> (CTerm (a1 -> b) -> CTerm (a1 -> c))
-> CTerm ((a1 -> b) -> a1 -> c)
forall a b. (a -> b) -> a -> b
$ \CTerm (a1 -> b)
g -> (CTerm a1 -> CTerm c) -> CTerm (a1 -> c)
forall a b. (CTerm a -> CTerm b) -> CTerm (a -> b)
CFun ((CTerm a1 -> CTerm c) -> CTerm (a1 -> c))
-> (CTerm a1 -> CTerm c) -> CTerm (a1 -> c)
forall a b. (a -> b) -> a -> b
$ \CTerm a1
x -> CTerm (b -> c)
f CTerm (b -> c) -> CTerm b -> CTerm c
forall a b. CTerm (a -> b) -> CTerm a -> CTerm b
forall (t :: * -> *) a b. Applicable t => t (a -> b) -> t a -> t b
$$ (CTerm (a1 -> b)
g CTerm (a1 -> b) -> CTerm a1 -> CTerm b
forall a b. CTerm (a -> b) -> CTerm a -> CTerm b
forall (t :: * -> *) a b. Applicable t => t (a -> b) -> t a -> t b
$$ CTerm a1
x)
  Const a
C -> (CTerm (a1 -> b -> c) -> CTerm (b -> a1 -> c))
-> CTerm ((a1 -> b -> c) -> b -> a1 -> c)
forall a b. (CTerm a -> CTerm b) -> CTerm (a -> b)
CFun ((CTerm (a1 -> b -> c) -> CTerm (b -> a1 -> c))
 -> CTerm ((a1 -> b -> c) -> b -> a1 -> c))
-> (CTerm (a1 -> b -> c) -> CTerm (b -> a1 -> c))
-> CTerm ((a1 -> b -> c) -> b -> a1 -> c)
forall a b. (a -> b) -> a -> b
$ \CTerm (a1 -> b -> c)
f -> (CTerm b -> CTerm (a1 -> c)) -> CTerm (b -> a1 -> c)
forall a b. (CTerm a -> CTerm b) -> CTerm (a -> b)
CFun ((CTerm b -> CTerm (a1 -> c)) -> CTerm (b -> a1 -> c))
-> (CTerm b -> CTerm (a1 -> c)) -> CTerm (b -> a1 -> c)
forall a b. (a -> b) -> a -> b
$ \CTerm b
x -> (CTerm a1 -> CTerm c) -> CTerm (a1 -> c)
forall a b. (CTerm a -> CTerm b) -> CTerm (a -> b)
CFun ((CTerm a1 -> CTerm c) -> CTerm (a1 -> c))
-> (CTerm a1 -> CTerm c) -> CTerm (a1 -> c)
forall a b. (a -> b) -> a -> b
$ \CTerm a1
y -> CTerm (a1 -> b -> c)
f CTerm (a1 -> b -> c) -> CTerm a1 -> CTerm (b -> c)
forall a b. CTerm (a -> b) -> CTerm a -> CTerm b
forall (t :: * -> *) a b. Applicable t => t (a -> b) -> t a -> t b
$$ CTerm a1
y CTerm (b -> c) -> CTerm b -> CTerm c
forall a b. CTerm (a -> b) -> CTerm a -> CTerm b
forall (t :: * -> *) a b. Applicable t => t (a -> b) -> t a -> t b
$$ CTerm b
x
  Const a
Φ -> (CTerm (a1 -> b -> c) -> CTerm ((d -> a1) -> (d -> b) -> d -> c))
-> CTerm ((a1 -> b -> c) -> (d -> a1) -> (d -> b) -> d -> c)
forall a b. (CTerm a -> CTerm b) -> CTerm (a -> b)
CFun ((CTerm (a1 -> b -> c) -> CTerm ((d -> a1) -> (d -> b) -> d -> c))
 -> CTerm ((a1 -> b -> c) -> (d -> a1) -> (d -> b) -> d -> c))
-> (CTerm (a1 -> b -> c)
    -> CTerm ((d -> a1) -> (d -> b) -> d -> c))
-> CTerm ((a1 -> b -> c) -> (d -> a1) -> (d -> b) -> d -> c)
forall a b. (a -> b) -> a -> b
$ \CTerm (a1 -> b -> c)
c -> (CTerm (d -> a1) -> CTerm ((d -> b) -> d -> c))
-> CTerm ((d -> a1) -> (d -> b) -> d -> c)
forall a b. (CTerm a -> CTerm b) -> CTerm (a -> b)
CFun ((CTerm (d -> a1) -> CTerm ((d -> b) -> d -> c))
 -> CTerm ((d -> a1) -> (d -> b) -> d -> c))
-> (CTerm (d -> a1) -> CTerm ((d -> b) -> d -> c))
-> CTerm ((d -> a1) -> (d -> b) -> d -> c)
forall a b. (a -> b) -> a -> b
$ \CTerm (d -> a1)
f -> (CTerm (d -> b) -> CTerm (d -> c)) -> CTerm ((d -> b) -> d -> c)
forall a b. (CTerm a -> CTerm b) -> CTerm (a -> b)
CFun ((CTerm (d -> b) -> CTerm (d -> c)) -> CTerm ((d -> b) -> d -> c))
-> (CTerm (d -> b) -> CTerm (d -> c)) -> CTerm ((d -> b) -> d -> c)
forall a b. (a -> b) -> a -> b
$ \CTerm (d -> b)
g -> (CTerm d -> CTerm c) -> CTerm (d -> c)
forall a b. (CTerm a -> CTerm b) -> CTerm (a -> b)
CFun ((CTerm d -> CTerm c) -> CTerm (d -> c))
-> (CTerm d -> CTerm c) -> CTerm (d -> c)
forall a b. (a -> b) -> a -> b
$ \CTerm d
x -> CTerm (a1 -> b -> c)
c CTerm (a1 -> b -> c) -> CTerm a1 -> CTerm (b -> c)
forall a b. CTerm (a -> b) -> CTerm a -> CTerm b
forall (t :: * -> *) a b. Applicable t => t (a -> b) -> t a -> t b
$$ (CTerm (d -> a1)
f CTerm (d -> a1) -> CTerm d -> CTerm a1
forall a b. CTerm (a -> b) -> CTerm a -> CTerm b
forall (t :: * -> *) a b. Applicable t => t (a -> b) -> t a -> t b
$$ CTerm d
x) CTerm (b -> c) -> CTerm b -> CTerm c
forall a b. CTerm (a -> b) -> CTerm a -> CTerm b
forall (t :: * -> *) a b. Applicable t => t (a -> b) -> t a -> t b
$$ (CTerm (d -> b)
g CTerm (d -> b) -> CTerm d -> CTerm b
forall a b. CTerm (a -> b) -> CTerm a -> CTerm b
forall (t :: * -> *) a b. Applicable t => t (a -> b) -> t a -> t b
$$ CTerm d
x)

unary :: (NotFun a, NotFun b) => (a -> b) -> CTerm (a -> b)
unary :: forall a b. (NotFun a, NotFun b) => (a -> b) -> CTerm (a -> b)
unary a -> b
op = (CTerm a -> CTerm b) -> CTerm (a -> b)
forall a b. (CTerm a -> CTerm b) -> CTerm (a -> b)
CFun ((CTerm a -> CTerm b) -> CTerm (a -> b))
-> (CTerm a -> CTerm b) -> CTerm (a -> b)
forall a b. (a -> b) -> a -> b
$ \(CConst a
x) -> b -> CTerm b
forall a. NotFun a => a -> CTerm a
CConst (a -> b
op a
x)

binary :: (NotFun a, NotFun b, NotFun c) => (a -> b -> c) -> CTerm (a -> b -> c)
binary :: forall a b c.
(NotFun a, NotFun b, NotFun c) =>
(a -> b -> c) -> CTerm (a -> b -> c)
binary a -> b -> c
op = (CTerm a -> CTerm (b -> c)) -> CTerm (a -> b -> c)
forall a b. (CTerm a -> CTerm b) -> CTerm (a -> b)
CFun ((CTerm a -> CTerm (b -> c)) -> CTerm (a -> b -> c))
-> (CTerm a -> CTerm (b -> c)) -> CTerm (a -> b -> c)
forall a b. (a -> b) -> a -> b
$ \(CConst a
x) -> (CTerm b -> CTerm c) -> CTerm (b -> c)
forall a b. (CTerm a -> CTerm b) -> CTerm (a -> b)
CFun ((CTerm b -> CTerm c) -> CTerm (b -> c))
-> (CTerm b -> CTerm c) -> CTerm (b -> c)
forall a b. (a -> b) -> a -> b
$ \(CConst b
y) -> c -> CTerm c
forall a. NotFun a => a -> CTerm a
CConst (a -> b -> c
op a
x b
y)

-- Note we could desugar 'mask p a -> if p a empty' but that would
-- require an explicit 'empty' node, whose type can't be inferred.
compileMask :: (NotFun a, Empty a) => CTerm (World Bool -> World a -> World a)
compileMask :: forall a.
(NotFun a, Empty a) =>
CTerm (World Bool -> World a -> World a)
compileMask = (CTerm (World Bool) -> CTerm (World a -> World a))
-> CTerm (World Bool -> World a -> World a)
forall a b. (CTerm a -> CTerm b) -> CTerm (a -> b)
CFun ((CTerm (World Bool) -> CTerm (World a -> World a))
 -> CTerm (World Bool -> World a -> World a))
-> (CTerm (World Bool) -> CTerm (World a -> World a))
-> CTerm (World Bool -> World a -> World a)
forall a b. (a -> b) -> a -> b
$ \CTerm (World Bool)
p -> (CTerm (World a) -> CTerm (World a)) -> CTerm (World a -> World a)
forall a b. (CTerm a -> CTerm b) -> CTerm (a -> b)
CFun ((CTerm (World a) -> CTerm (World a))
 -> CTerm (World a -> World a))
-> (CTerm (World a) -> CTerm (World a))
-> CTerm (World a -> World a)
forall a b. (a -> b) -> a -> b
$ \CTerm (World a)
a -> (CTerm Coords -> CTerm a) -> CTerm (World a)
forall a b. (CTerm a -> CTerm b) -> CTerm (a -> b)
CFun ((CTerm Coords -> CTerm a) -> CTerm (World a))
-> (CTerm Coords -> CTerm a) -> CTerm (World a)
forall a b. (a -> b) -> a -> b
$ \CTerm Coords
ix ->
  case CTerm (World Bool)
p CTerm (World Bool) -> CTerm Coords -> CTerm Bool
forall a b. CTerm (a -> b) -> CTerm a -> CTerm b
forall (t :: * -> *) a b. Applicable t => t (a -> b) -> t a -> t b
$$ CTerm Coords
ix of
    CConst Bool
b -> if Bool
b then CTerm (World a)
a CTerm (World a) -> CTerm Coords -> CTerm a
forall a b. CTerm (a -> b) -> CTerm a -> CTerm b
forall (t :: * -> *) a b. Applicable t => t (a -> b) -> t a -> t b
$$ CTerm Coords
ix else a -> CTerm a
forall a. NotFun a => a -> CTerm a
CConst a
forall e. Empty e => e
empty

compileHash :: Seed -> CTerm (Coords -> Integer)
compileHash :: Seed -> CTerm (Coords -> Integer)
compileHash Seed
seed = (CTerm Coords -> CTerm Integer) -> CTerm (Coords -> Integer)
forall a b. (CTerm a -> CTerm b) -> CTerm (a -> b)
CFun ((CTerm Coords -> CTerm Integer) -> CTerm (Coords -> Integer))
-> (CTerm Coords -> CTerm Integer) -> CTerm (Coords -> Integer)
forall a b. (a -> b) -> a -> b
$ \(CConst (Coords (Int32, Int32)
ix)) -> Integer -> CTerm Integer
forall a. NotFun a => a -> CTerm a
CConst (Word32 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral ((Int32, Int32) -> Word32
h (Int32, Int32)
ix))
 where
  h :: (Int32, Int32) -> Word32
h = 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

compilePerlin :: CTerm (Integer -> Integer -> Double -> Double -> World Double)
compilePerlin :: CTerm (Integer -> Integer -> Double -> Double -> World Double)
compilePerlin =
  (CTerm Integer
 -> CTerm (Integer -> Double -> Double -> World Double))
-> CTerm (Integer -> Integer -> Double -> Double -> World Double)
forall a b. (CTerm a -> CTerm b) -> CTerm (a -> b)
CFun ((CTerm Integer
  -> CTerm (Integer -> Double -> Double -> World Double))
 -> CTerm (Integer -> Integer -> Double -> Double -> World Double))
-> (CTerm Integer
    -> CTerm (Integer -> Double -> Double -> World Double))
-> CTerm (Integer -> Integer -> Double -> Double -> World Double)
forall a b. (a -> b) -> a -> b
$ \(CConst Integer
s) ->
    (CTerm Integer -> CTerm (Double -> Double -> World Double))
-> CTerm (Integer -> Double -> Double -> World Double)
forall a b. (CTerm a -> CTerm b) -> CTerm (a -> b)
CFun ((CTerm Integer -> CTerm (Double -> Double -> World Double))
 -> CTerm (Integer -> Double -> Double -> World Double))
-> (CTerm Integer -> CTerm (Double -> Double -> World Double))
-> CTerm (Integer -> Double -> Double -> World Double)
forall a b. (a -> b) -> a -> b
$ \(CConst Integer
o) ->
      (CTerm Double -> CTerm (Double -> World Double))
-> CTerm (Double -> Double -> World Double)
forall a b. (CTerm a -> CTerm b) -> CTerm (a -> b)
CFun ((CTerm Double -> CTerm (Double -> World Double))
 -> CTerm (Double -> Double -> World Double))
-> (CTerm Double -> CTerm (Double -> World Double))
-> CTerm (Double -> Double -> World Double)
forall a b. (a -> b) -> a -> b
$ \(CConst Double
k) ->
        (CTerm Double -> CTerm (World Double))
-> CTerm (Double -> World Double)
forall a b. (CTerm a -> CTerm b) -> CTerm (a -> b)
CFun ((CTerm Double -> CTerm (World Double))
 -> CTerm (Double -> World Double))
-> (CTerm Double -> CTerm (World Double))
-> CTerm (Double -> World Double)
forall a b. (a -> b) -> a -> b
$ \(CConst 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
           in (CTerm Coords -> CTerm Double) -> CTerm (World Double)
forall a b. (CTerm a -> CTerm b) -> CTerm (a -> b)
CFun ((CTerm Coords -> CTerm Double) -> CTerm (World Double))
-> (CTerm Coords -> CTerm Double) -> CTerm (World Double)
forall a b. (a -> b) -> a -> b
$ \(CConst (Coords (Int32, Int32)
ix)) -> Double -> CTerm Double
forall a. NotFun a => a -> CTerm a
CConst ((Int32, Int32) -> Perlin -> Double
forall {a} {a} {a}.
(Noise a, Integral a, Integral a) =>
(a, a) -> a -> Double
sample (Int32, Int32)
ix Perlin
noise)
 where
  sample :: (a, a) -> a -> Double
sample (a
i, a
j) a
noise = a -> Point -> Double
forall a. Noise a => a -> Point -> Double
noiseValue a
noise (a -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
i Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
2, a -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
j Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
2, Double
0)

compileIMap :: NotFun a => CTerm (World Integer -> World Integer -> World a -> World a)
compileIMap :: forall a.
NotFun a =>
CTerm
  ((Coords -> Integer) -> (Coords -> Integer) -> World a -> World a)
compileIMap =
  (CTerm (Coords -> Integer)
 -> CTerm ((Coords -> Integer) -> World a -> World a))
-> CTerm
     ((Coords -> Integer) -> (Coords -> Integer) -> World a -> World a)
forall a b. (CTerm a -> CTerm b) -> CTerm (a -> b)
CFun ((CTerm (Coords -> Integer)
  -> CTerm ((Coords -> Integer) -> World a -> World a))
 -> CTerm
      ((Coords -> Integer) -> (Coords -> Integer) -> World a -> World a))
-> (CTerm (Coords -> Integer)
    -> CTerm ((Coords -> Integer) -> World a -> World a))
-> CTerm
     ((Coords -> Integer) -> (Coords -> Integer) -> World a -> World a)
forall a b. (a -> b) -> a -> b
$ \CTerm (Coords -> Integer)
wx ->
    (CTerm (Coords -> Integer) -> CTerm (World a -> World a))
-> CTerm ((Coords -> Integer) -> World a -> World a)
forall a b. (CTerm a -> CTerm b) -> CTerm (a -> b)
CFun ((CTerm (Coords -> Integer) -> CTerm (World a -> World a))
 -> CTerm ((Coords -> Integer) -> World a -> World a))
-> (CTerm (Coords -> Integer) -> CTerm (World a -> World a))
-> CTerm ((Coords -> Integer) -> World a -> World a)
forall a b. (a -> b) -> a -> b
$ \CTerm (Coords -> Integer)
wy ->
      (CTerm (World a) -> CTerm (World a)) -> CTerm (World a -> World a)
forall a b. (CTerm a -> CTerm b) -> CTerm (a -> b)
CFun ((CTerm (World a) -> CTerm (World a))
 -> CTerm (World a -> World a))
-> (CTerm (World a) -> CTerm (World a))
-> CTerm (World a -> World a)
forall a b. (a -> b) -> a -> b
$ \CTerm (World a)
wa ->
        (CTerm Coords -> CTerm a) -> CTerm (World a)
forall a b. (CTerm a -> CTerm b) -> CTerm (a -> b)
CFun ((CTerm Coords -> CTerm a) -> CTerm (World a))
-> (CTerm Coords -> CTerm a) -> CTerm (World a)
forall a b. (a -> b) -> a -> b
$ \CTerm Coords
c ->
          let mkCoords :: CTerm Integer -> CTerm Integer -> CTerm Coords
              mkCoords :: CTerm Integer -> CTerm Integer -> CTerm Coords
mkCoords (CConst Integer
x) (CConst Integer
y) = Coords -> CTerm Coords
forall a. NotFun a => a -> CTerm a
CConst (Location -> Coords
locToCoords (Int32 -> Int32 -> Location
Location (Integer -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
x) (Integer -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
y)))
           in CTerm (World a)
wa CTerm (World a) -> CTerm Coords -> CTerm a
forall a b. CTerm (a -> b) -> CTerm a -> CTerm b
forall (t :: * -> *) a b. Applicable t => t (a -> b) -> t a -> t b
$$ CTerm Integer -> CTerm Integer -> CTerm Coords
mkCoords (CTerm (Coords -> Integer)
wx CTerm (Coords -> Integer) -> CTerm Coords -> CTerm Integer
forall a b. CTerm (a -> b) -> CTerm a -> CTerm b
forall (t :: * -> *) a b. Applicable t => t (a -> b) -> t a -> t b
$$ CTerm Coords
c) (CTerm (Coords -> Integer)
wy CTerm (Coords -> Integer) -> CTerm Coords -> CTerm Integer
forall a b. CTerm (a -> b) -> CTerm a -> CTerm b
forall (t :: * -> *) a b. Applicable t => t (a -> b) -> t a -> t b
$$ CTerm Coords
c)

type family NoFunParams a :: Constraint where
  NoFunParams (a -> b) = (NotFun a, NoFunParams b)
  NoFunParams _ = ()

-- | Interpret a compiled term into the host language.
runCTerm :: (NoFunParams a) => CTerm a -> a
runCTerm :: forall a. NoFunParams a => CTerm a -> a
runCTerm (CConst a
a) = a
a
runCTerm (CFun CTerm a -> CTerm b
f) = CTerm b -> b
forall a. NoFunParams a => CTerm a -> a
runCTerm (CTerm b -> b) -> (a -> CTerm b) -> a -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CTerm a -> CTerm b
f (CTerm a -> CTerm b) -> (a -> CTerm a) -> a -> CTerm b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> CTerm a
forall a. NotFun a => a -> CTerm a
CConst