{-# LANGUAGE RebindableSyntax #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Copilot.FRPSketch where

import Copilot.FRPSketch.Internals
import Language.Copilot hiding (ifThenElse)
import qualified Language.Copilot
import Data.Maybe

-- | Use this to make a LED blink on and off.
--
-- On each iteration of the `Sketch`, this changes to the opposite of its
-- previous value.
--
-- This is implemented using Copilot's `clk`, so to get other blinking
-- behaviors, just pick different numbers, or use Copilot `Stream`
-- combinators.
--
-- > blinking = clk (period 2) (phase 1)
blinking :: Behavior Bool
blinking :: Behavior Bool
blinking = Period Integer -> Phase Integer -> Behavior Bool
forall a. Integral a => Period a -> Phase a -> Behavior Bool
clk (Integer -> Period Integer
forall a. Integral a => a -> Period a
period (Integer
2 :: Integer)) (Integer -> Phase Integer
forall a. Integral a => a -> Phase a
phase (Integer
1 :: Integer))

-- | True on the first iteration of the `Sketch`, and False thereafter.
firstIteration :: Behavior Bool
firstIteration :: Behavior Bool
firstIteration = [Bool
True][Bool] -> Behavior Bool -> Behavior Bool
forall a. Typed a => [a] -> Stream a -> Stream a
++Behavior Bool
false

-- | Use this to make an event occur 1 time out of n.
--
-- This is implemented using Copilot's `clk`:
--
-- > frequency = clk (period n) (phase 1)
frequency :: Integer -> Behavior Bool
frequency :: Integer -> Behavior Bool
frequency Integer
n = Period Integer -> Phase Integer -> Behavior Bool
forall a. Integral a => Period a -> Phase a -> Behavior Bool
clk (Integer -> Period Integer
forall a. Integral a => a -> Period a
period Integer
n) (Integer -> Phase Integer
forall a. Integral a => a -> Phase a
phase Integer
1)

-- | A stream of milliseconds.
data MilliSeconds = MilliSeconds (Stream Word32)

-- | A stream of microseconds.
data MicroSeconds = MicroSeconds (Stream Word32)

-- | Use this to add a delay between each iteration of the `Sketch`.
-- A `Sketch` with no delay will run as fast as the hardware can run it.
--
-- > delay := MilliSeconds (constant 100)
delay :: Delay
delay :: Delay
delay = Delay
Delay

data Delay = Delay

class IfThenElse t a where
	-- | This allows "if then else" expressions to be written
	-- that choose between two Streams, or Behaviors, or TypedBehaviors,
	-- or Sketches, when the RebindableSyntax language extension is
	-- enabled.
	--
	-- > {-# LANGUAGE RebindableSyntax #-}
	-- > buttonpressed <- input pin3
	-- > if buttonpressed then ... else ...
	ifThenElse :: Behavior Bool -> t a -> t a -> t a

instance Typed a => IfThenElse Stream a where
	ifThenElse :: Behavior Bool -> Stream a -> Stream a -> Stream a
ifThenElse = Behavior Bool -> Stream a -> Stream a -> Stream a
forall a.
Typed a =>
Behavior Bool -> Stream a -> Stream a -> Stream a
Language.Copilot.ifThenElse

instance Typed a => IfThenElse (TypedBehavior p) a where
	ifThenElse :: Behavior Bool
-> TypedBehavior p a -> TypedBehavior p a -> TypedBehavior p a
ifThenElse Behavior Bool
c (TypedBehavior Behavior a
a) (TypedBehavior Behavior a
b) =
		Behavior a -> TypedBehavior p a
forall k (p :: k) t. Behavior t -> TypedBehavior p t
TypedBehavior (Behavior Bool -> Behavior a -> Behavior a -> Behavior a
forall (t :: * -> *) a.
IfThenElse t a =>
Behavior Bool -> t a -> t a -> t a
ifThenElse Behavior Bool
c Behavior a
a Behavior a
b)

instance Ord pinid => IfThenElse (GenSketch pinid) () where
	ifThenElse :: Behavior Bool
-> GenSketch pinid () -> GenSketch pinid () -> GenSketch pinid ()
ifThenElse Behavior Bool
c GenSketch pinid ()
a GenSketch pinid ()
b = do
		Behavior Bool -> GenSketch pinid () -> GenSketch pinid ()
forall pinid t.
Ord pinid =>
Behavior Bool -> GenSketch pinid t -> GenSketch pinid t
whenB Behavior Bool
c GenSketch pinid ()
a
		Behavior Bool -> GenSketch pinid () -> GenSketch pinid ()
forall pinid t.
Ord pinid =>
Behavior Bool -> GenSketch pinid t -> GenSketch pinid t
whenB (Behavior Bool -> Behavior Bool
not Behavior Bool
c) GenSketch pinid ()
b

instance (Ord pinid, Typed a) => IfThenElse (GenSketch pinid) (Behavior a) where
	ifThenElse :: Behavior Bool
-> GenSketch pinid (Behavior a)
-> GenSketch pinid (Behavior a)
-> GenSketch pinid (Behavior a)
ifThenElse Behavior Bool
c GenSketch pinid (Behavior a)
a GenSketch pinid (Behavior a)
b = do
		Behavior a
ra <- Behavior Bool
-> GenSketch pinid (Behavior a) -> GenSketch pinid (Behavior a)
forall pinid t.
Ord pinid =>
Behavior Bool -> GenSketch pinid t -> GenSketch pinid t
whenB Behavior Bool
c GenSketch pinid (Behavior a)
a
		Behavior a
rb <- Behavior Bool
-> GenSketch pinid (Behavior a) -> GenSketch pinid (Behavior a)
forall pinid t.
Ord pinid =>
Behavior Bool -> GenSketch pinid t -> GenSketch pinid t
whenB (Behavior Bool -> Behavior Bool
not Behavior Bool
c) GenSketch pinid (Behavior a)
b
		Behavior a -> GenSketch pinid (Behavior a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Behavior a -> GenSketch pinid (Behavior a))
-> Behavior a -> GenSketch pinid (Behavior a)
forall a b. (a -> b) -> a -> b
$ Behavior Bool -> Behavior a -> Behavior a -> Behavior a
forall a.
Typed a =>
Behavior Bool -> Stream a -> Stream a -> Stream a
Language.Copilot.ifThenElse Behavior Bool
c Behavior a
ra Behavior a
rb

-- | Schedule when to perform different Sketches.
scheduleB
	:: (Typed t, Eq t, Ord pinid)
	=> Behavior t
	-> [(t, GenSketch pinid ())]
	-> GenSketch pinid ()
scheduleB :: Behavior t -> [(t, GenSketch pinid ())] -> GenSketch pinid ()
scheduleB Behavior t
b = [GenSketch pinid ()] -> GenSketch pinid ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ ([GenSketch pinid ()] -> GenSketch pinid ())
-> ([(t, GenSketch pinid ())] -> [GenSketch pinid ()])
-> [(t, GenSketch pinid ())]
-> GenSketch pinid ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((t, GenSketch pinid ()) -> GenSketch pinid ())
-> [(t, GenSketch pinid ())] -> [GenSketch pinid ()]
forall a b. (a -> b) -> [a] -> [b]
map (t, GenSketch pinid ()) -> GenSketch pinid ()
forall pinid t.
Ord pinid =>
(t, GenSketch pinid t) -> GenSketch pinid t
go
  where
	go :: (t, GenSketch pinid t) -> GenSketch pinid t
go (t
v, GenSketch pinid t
s) = Behavior Bool -> GenSketch pinid t -> GenSketch pinid t
forall pinid t.
Ord pinid =>
Behavior Bool -> GenSketch pinid t -> GenSketch pinid t
whenB (Behavior t
b Behavior t -> Behavior t -> Behavior Bool
forall a. (Eq a, Typed a) => Stream a -> Stream a -> Behavior Bool
== t -> Behavior t
forall a. Typed a => a -> Stream a
constant t
v) GenSketch pinid t
s

-- | Extracts a copilot `Spec` from a `Sketch`.
--
-- This can be useful to intergrate with other libraries 
-- such as copilot-theorem.
sketchSpec :: Ord pinid => GenSketch pinid a -> Spec
sketchSpec :: GenSketch pinid a -> Spec
sketchSpec = Spec -> Maybe Spec -> Spec
forall a. a -> Maybe a -> a
fromMaybe (() -> Spec
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (Maybe Spec -> Spec)
-> (GenSketch pinid a -> Maybe Spec) -> GenSketch pinid a -> Spec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe Spec, GenFramework pinid) -> Maybe Spec
forall a b. (a, b) -> a
fst ((Maybe Spec, GenFramework pinid) -> Maybe Spec)
-> (GenSketch pinid a -> (Maybe Spec, GenFramework pinid))
-> GenSketch pinid a
-> Maybe Spec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenSketch pinid a -> (Maybe Spec, GenFramework pinid)
forall pinid a.
Ord pinid =>
GenSketch pinid a -> (Maybe Spec, GenFramework pinid)
evalSketch

-- | Apply a Copilot DSL function to a `TypedBehavior`.
liftB
	:: (Behavior a -> Behavior r)
	-> TypedBehavior t a
	-> Behavior r
liftB :: (Behavior a -> Behavior r) -> TypedBehavior t a -> Behavior r
liftB Behavior a -> Behavior r
f (TypedBehavior Behavior a
b) = Behavior a -> Behavior r
f Behavior a
b

-- | Apply a Copilot DSL function to two `TypedBehavior`s.
liftB2
	:: (Behavior a -> Behavior b -> Behavior r)
	-> TypedBehavior t a
	-> TypedBehavior t b
	-> Behavior r
liftB2 :: (Behavior a -> Behavior b -> Behavior r)
-> TypedBehavior t a -> TypedBehavior t b -> Behavior r
liftB2 Behavior a -> Behavior b -> Behavior r
f (TypedBehavior Behavior a
a) (TypedBehavior Behavior b
b) = Behavior a -> Behavior b -> Behavior r
f Behavior a
a Behavior b
b