module Hedgehog.Internal.Seed

import Data.Bounded
import Data.Bits
import Data.DPair
import Data.Fin

import Generics.Derive

%default total

%language ElabReflection

--------------------------------------------------------------------------------
--          Implementation Utilities
--------------------------------------------------------------------------------

shiftXor : Index {a = Bits64} -> Bits64 -> Bits64
shiftXor n w = w `xor` (w `shiftR` n)

shiftXorMultiply : Index {a = Bits64} -> Bits64 -> Bits64 -> Bits64
shiftXorMultiply n k w = shiftXor n w * k

-- Note: in JDK implementations the mix64 and mix64variant13
-- (which is inlined into mixGamma) are swapped.
mix64 : Bits64 -> Bits64
mix64 z0 =
   -- MurmurHash3Mixer
    let z1 = shiftXorMultiply 33 0xff51afd7ed558ccd z0
        z2 = shiftXorMultiply 33 0xc4ceb9fe1a85ec53 z1
        z3 = shiftXor 33 z2
    in z3

-- used only in mixGamma
mix64variant13 : Bits64 -> Bits64
mix64variant13 z0 =
   -- Better Bit Mixing - Improving on MurmurHash3's 64-bit Finalizer
   -- http://zimbry.blogspot.fi/2011/09/better-bit-mixing-improving-on.html
   --
   -- Stafford's Mix13
    let z1 = shiftXorMultiply 30 0xbf58476d1ce4e5b9 z0 -- MurmurHash3 mix constants
        z2 = shiftXorMultiply 27 0x94d049bb133111eb z1
        z3 = shiftXor 31 z2
    in z3

mixGamma : Bits64 -> Bits64
mixGamma z0 =
    let z1 = mix64variant13 z0 .|. 1             -- force to be odd
        n  = popCount (z1 `xor` (z1 `shiftR` 1))
    -- see: http://www.pcg-random.org/posts/bugs-in-splitmix.html
    -- let's trust the text of the paper, not the code.
    in if n >= 24
        then z1
        else z1 `xor` 0xaaaaaaaaaaaaaaaa

goldenGamma : Bits64
goldenGamma = 0x9e3779b97f4a7c15

bits64ToDouble : Bits64 -> Double
bits64ToDouble = fromInteger . cast

doubleUlp : Double
doubleUlp =  1.0 / bits64ToDouble (1 `shiftL` 53)

mask : Bits64 -> Bits64
mask n = sl 1
       . sl 2
       . sl 4
       . sl 8
       . sl 16
       $ sl 32 maxBound
  where sl : Index {a = Bits64} -> Bits64 -> Bits64
        sl s x = let x' = shiftR x s
                  in if x' < n then x else x'

two64 : Integer
two64 = 1 `shiftL` 64

--------------------------------------------------------------------------------
--          Seed
--------------------------------------------------------------------------------

public export
data Seed = MkSeed Bits64 Bits64

%runElab derive "Seed" [Generic,Meta,Eq,Show]

||| Create an Seed from the given seed.
export
smGen : Bits64 -> Seed
smGen s = MkSeed (mix64 s) (mixGamma (s + goldenGamma))

%foreign "scheme:blodwen-random"
         "javascript:lambda:x=>BigInt(Math.floor(Math.random() * Number(x)))"
prim__random_Bits64 : Bits64 -> PrimIO Bits64

||| Initialize 'SMGen' using entropy available on the system (time, ...)
export
initSMGen : HasIO io => io Seed
initSMGen = liftIO
          . map smGen
          $ fromPrim (prim__random_Bits64 maxBound)

||| Split a generator into a two uncorrelated generators.
|||
||| Note: This is `splitSMGen` in Haskell
export
split : Seed -> (Seed, Seed)
split (MkSeed seed gamma) =
  let seed'  = seed  + gamma
      seed'' = seed' + gamma
   in (MkSeed seed'' gamma, MkSeed (mix64 seed') (mixGamma seed''))

||| Generates a 64-bit value
export
nextBits64 : Seed -> (Bits64, Seed)
nextBits64 (MkSeed seed gamma) = let seed' = seed + gamma
                                  in (mix64 seed', MkSeed seed' gamma)

||| Generate a `Double` in [0, 1) range.
export
nextDouble : Seed -> (Double, Seed)
nextDouble g = let (w64,g') = nextBits64 g
                in (bits64ToDouble (w64 `shiftR` 11) * doubleUlp, g')

||| Generate a `Double` in [x, y) range.
export
nextDoubleR : (lower: Double) -> (upper: Double) -> Seed -> (Double, Seed)
nextDoubleR x y = let g = \l,u => let diff = u - l
                                   in mapFst (\f => l + f * diff) . nextDouble
                   in if x <= y then g x y else g y x

--------------------------------------------------------------------------------
--          Generating Integer Ranges
--------------------------------------------------------------------------------

||| Generates values in the closed interval [0,range].
export
nextBits64R : (range : Bits64) -> Seed -> (Bits64,Seed)
nextBits64R range = go 100 (mask range)
  where go : Nat -> Bits64 -> Seed -> (Bits64, Seed)
        go 0 _ gv       = (0,gv)
        go (S k) msk gv = let (x,gv') = nextBits64 gv
                              x' = x .&. msk
                           in if x' > range
                                then go k msk gv'
                                else (x', gv')

-- bitmask with rejection for Integers.
nextIntegerImpl : Integer -> Seed -> (Integer,Seed)
nextIntegerImpl range = let (leadMask,restDigits) = calc 0 range
                         in loop 100 leadMask restDigits
  where calc : Nat -> Integer -> (Bits64,Nat)
        calc n x  = if x < two64
                       then (mask $ cast x, n)
                       else calc (n + 1) (assert_smaller x (x `shiftR` 64))

        go : Integer -> Nat -> Seed -> (Integer, Seed)
        go acc 0     g = (acc, g)
        go acc (S k) g = let (x, g') = nextBits64 g
                          in go (shiftL acc 64 .|. cast x) k g'

        loop : Nat -> Bits64 -> Nat -> Seed -> (Integer,Seed)
        loop 0     _   _ gv = (0,gv)
        loop (S k) bm rd g0 = let (x,g1) = nextBits64 g0
                                  (n,g') = go (cast $ x .&. bm) rd g1
                               in if n <= range
                                    then (n,g')
                                    else loop k bm rd g'

export
nextIntegerR : (Integer,Integer) -> Seed -> (Integer,Seed)
nextIntegerR (x,y) = let f = \l,u => mapFst (l+) . nextIntegerImpl (u-l)
                      in if x <= y then f x y else f y x


module Control.Applicative.Syntax

--------------------------------------------------------------------------------
--          mapN etc
--------------------------------------------------------------------------------

public export
map2 : Functor f => Functor g => (a -> b) -> (f . g) a -> (f . g) b
map2 = map . map

public export
map3 :  Functor f => Functor g => Functor h
     => (a -> b) -> (f . g . h) a -> (f . g . h) b
map3 = map . map . map

public export
map4 :  Functor f => Functor g => Functor h => Functor i
     => (a -> b) -> (f . g . h . i) a -> (f . g . h . i) b
map4 = map . map . map . map

infixr 4 <$$>, <$$$>, <$$$$>
infixl 3 <**>, <***>, <****>

public export
(<$$>) : Functor f => Functor g => (a -> b) -> (f . g) a -> (f . g) b
(<$$>) = map . map

public export
(<$$$>) :  Functor f => Functor g => Functor h
        => (a -> b) -> (f . g . h) a -> (f . g . h) b
(<$$$>) = map . map . map

public export
(<$$$$>) :  Functor f => Functor g => Functor h => Functor i
         => (a -> b) -> (f . g . h . i) a -> (f . g . h . i) b
(<$$$$>) = map . map . map . map

public export
(<**>) :  Applicative f => Applicative g
       => (f . g) (a -> b) -> (f . g) a -> (f . g) b
x <**> y = [| x <*> y |]

public export
(<***>) :  Applicative f => Applicative g => Applicative h
        => (f . g . h) (a -> b) -> (f . g . h) a -> (f . g . h) b
x <***> y = [| x <**> y |]

public export
(<****>) :  Applicative f => Applicative g => Applicative h => Applicative i
         => (f . g . h . i) (a -> b) -> (f . g . h . i) a -> (f . g . h . i) b
x <****> y = [| x <***> y |]

--------------------------------------------------------------------------------
--          Implementations
--------------------------------------------------------------------------------

public export
record Comp2 (f,g : Type -> Type) (a : Type) where
  constructor C2
  c2 : f (g a)

public export
Functor f => Functor g => Functor (Comp2 f g) where
  map f (C2 v) = C2 $ map2 f v

public export
Applicative f => Applicative g => Applicative (Comp2 f g) where
  pure = C2 . pure . pure
  C2 vf <*> C2 va = C2 $ [| vf <*> va |]

public export
Foldable f => Foldable g => Foldable (Comp2 f g) where
  foldr fun acc (C2 v) =
    foldr (flip $ foldr fun) acc v
  foldl fun acc (C2 v) =
    foldl (foldl fun) acc v

public export
Traversable f => Traversable g => Traversable (Comp2 f g) where
  traverse fun = map C2 . (traverse . traverse) fun . c2


module Cordial.Model.Interface.Kinds

import Data.Vect
import Data.DList
import Data.Ranged

import Text.Markup.Edda

import Cordial.Model.Common
import Cordial.Model.Specification
import Cordial.Model.Projection

%default total
%access public export

||| What type of interface are we.
data InterfaceKind : (isMonitor : Bool)
                  -> (endpoint  : Endpoint)
                  -> Type
  where
    Producer  : InterfaceKind False PRODUCER
    Consumer  : InterfaceKind False CONSUMER

    System   : (e : Endpoint) -> InterfaceKind False e

    Monitor  : InterfaceKind True CONSUMER

namespace IKinds

   data InterfaceKinds : List (Bool, Endpoint) -> Type where
      Nil : InterfaceKinds Nil
      (::) : InterfaceKind b e
          -> InterfaceKinds kinds
          -> InterfaceKinds ((b,e)::kinds)

   {- [ NOTE ]

   I would rather replace `InterfaceKinds` with a DList. However, type
   checking later on becomes problematic. Idris, for some reason,
   cannot resolve the types.

   -}


{-
'A'
'_'
'C'
True
False
True
True
False
True
-}
module Main

data D = A | B | C

adt : D -> IO Bool
adt A = pure True
adt C = pure True
adt _ = pure False

int : Int -> IO Bool
int 0          = pure True
int 2147483647 = pure True
int _          = pure False

char : Char -> IO Char
char 'C' = pure 'C'
char 'B' = pure 'B'
char 'A' = pure 'A'
char _   = pure '_'

printMap : (Traversable t, Show b) => (a -> IO b) -> t a -> IO ()
printMap f xs = for_ xs (\x => f x >>= printLn)

main : IO ()
main = do
  printMap char ['A', 'D', 'C']
  printMap int  [0, 1, 2147483647]
  printMap adt  [A, B, C]


-- ------------------------------------------------------ [ GettingStarted.idr ]
-- Module      : Exercises.Test.GettingStarted
-- Description : Test covering the Chapter 2 exercises in Edwin Brady's
--               book, "Type-Driven Development with Idris."
-- --------------------------------------------------------------------- [ EOH ]
module Exercises.Test.GettingStarted

import Exercises.GettingStarted

import Test.Helpers

import Data.Vect
%hide Data.Vect.overLength

%access export

private
testPalindrome' : String -> (String -> Bool) -> String -> Bool -> IO Bool
testPalindrome' label palindrome string isPalindrome =
  unwords [label, show string] `assertEqual'` isPalindrome $
  palindrome string

testPalindrome : String -> Bool -> IO Bool
testPalindrome = testPalindrome' "Simple.palindrome" Simple.palindrome

testPalindromeCI : String -> Bool -> IO Bool
testPalindromeCI =
  testPalindrome' "CaseInsensitive.palindrome" CaseInsensitive.palindrome

testLongPalindrome : String -> Bool -> IO Bool
testLongPalindrome =
  testPalindrome' "LongerThan10.palindrome" LongerThan10.palindrome

testPalindromeLen : Nat -> String -> Bool -> IO Bool
testPalindromeLen =
  testPalindrome' "LongerThanN.palindrome" . LongerThanN.palindrome

||| `"Hello, Idris world!"` has three words and 19 characters.
testCounts : IO Bool
testCounts =
  "counts" `assertEqual'` (3, 19) $
  counts "Hello, Idris world!"

||| `["One", "Two", "Three", "Four"]` has two strings over three characters.
testOverLength : IO Bool
testOverLength =
  "overLength" `assertEqual'` 2 $
  overLength 3 ["One", "Two", "Three", "Four"]

testTopTen : IO Bool
testTopTen =
  "topTen" `assertEqual'` [100,99..91] $
  topTen [1..100]

allTests : List (IO Bool)
allTests = [ testPalindrome "racecar" True
           , testPalindrome "race car" False
           , testPalindromeCI "Racecar" True
           , testLongPalindrome "racecar" False
           , testLongPalindrome "able was i ere i saw elba" True
           , testPalindromeLen 10 "racecar" False
           , testPalindromeLen 5 "racecar" True
           , testCounts
           , testTopTen
           , testOverLength
           ]

runTests : IO (Vect (length GettingStarted.allTests) Bool)
runTests = testChapter "2: Getting Started" allTests

-- --------------------------------------------------------------------- [ EOF ]


module Data.Functor.Of

infixl 0 :>

public export
record Of a b where
  constructor (:>)
  fst : a
  snd : Lazy b

export
Bifunctor Of where
  mapFst f (a :> b) = f a :> b
  mapSnd f (a :> b) = a :> f b
  bimap f g (a :> b) = f a :> g b

export
Functor (Of a) where
  map = mapSnd

export
from_pair : Pair a b -> Of a b
from_pair (a, b) = a :> b

export
to_pair : Of a b -> Pair a b
to_pair (a :> b) = (a, b)


import System.Concurrency.Channels

data Message = Add Nat Nat

data MessagePID = MkMessage PID

data ProcState = Ready | Sent | Looping

data Process : Type -> ProcState -> ProcState -> Type where
     Request : MessagePID -> Message -> Process Nat st st
     Respond : ((msg : Message) -> Process Nat Ready Ready) ->
               Process (Maybe Message) st Sent
     Spawn : Process () Ready Looping ->
             Process (Maybe MessagePID) st st

     Loop : Inf (Process a Ready Looping) ->
            Process a Sent Looping
     Action : IO a -> Process a st st
     Pure : a -> Process a st st
     (>>=) : Process a st1 st2 -> (a -> Process b st2 st3) ->
             Process b st1 st3

public export
data Fuel = Dry | More (Lazy Fuel)

export partial
forever : Fuel
forever = More forever

total
run : Fuel -> Process t in_state out_state -> IO (Maybe t)
run fuel (Request (MkMessage process) msg)
          = do Just chan <- connect process
                    | _ => pure Nothing
               ok <- unsafeSend chan msg
               if ok then do Just x <- unsafeRecv Nat chan
                                  | Nothing => pure Nothing
                             pure (Just x)
                     else pure Nothing
run fuel (Respond f)
          = do Just sender <- listen 1
                    | Nothing => pure (Just Nothing)
               Just msg <- unsafeRecv Message sender
                    | Nothing => pure (Just Nothing)
               Just res <- run fuel (f msg)
                    | Nothing => pure Nothing
               unsafeSend sender res
               pure (Just (Just msg))
run (More fuel) (Loop proc) = run fuel proc
run fuel (Spawn proc) = do Just pid <- spawn (do run fuel proc
                                                 pure ())
                                | Nothing => pure (Just Nothing)
                           pure (Just (Just (MkMessage pid)))
run fuel (Action act) = do res <- act
                           pure (Just res)
run fuel (Pure val) = pure (Just val)
run fuel (act >>= next) = do Just x <- run fuel act
                                  | Nothing => pure Nothing
                             run fuel (next x)
run Dry _ = pure Nothing

Service : Type -> Type
Service a = Process a Ready Looping

Client : Type -> Type
Client a = Process a Ready Ready

{-
procAdder_bad1 : Process () Ready Looping
procAdder_bad1 = do Action (putStrLn "I'm out of the office today")
                    Loop procAdder_bad1

procAdder_bad2 : Process () Ready Looping
procAdder_bad2 = Loop procAdder_bad2
                    -}

procAdder : Service ()
procAdder = do Respond (\msg => case msg of
                                     Add x y => Pure (x + y))
               Loop procAdder

procMain : Client ()
procMain = do Just adder_id <- Spawn procAdder
                   | Nothing => Action (putStrLn "Spawn failed")
              answer <- Request adder_id (Add 2 3)
              Action (printLn answer)

partial
runProc : Process () in_state out_state -> IO ()
runProc proc = do run forever proc
                  pure ()

main : IO ()
main = runProc procMain


|||
|||
||| Module    : Context.idr
||| Copyright : (c) Jan de Muijnck-Hughes
||| License   : see LICENSE
|||
module Toolkit.DeBruijn.Context

import Decidable.Equality

import Data.DPair
import Data.Singleton

import Toolkit.Decidable.Informative

import Toolkit.Data.List.AtIndex
import Toolkit.Data.DList
import Toolkit.Data.DList.AtIndex

import Toolkit.DeBruijn.Context.Item

%default total

-- A reverse cons operator.
infixr 6 +=

namespace List
  ||| Append `x` to the head of `xs`.
  public export
  (+=) : List a -> a -> List a
  (+=) xs x = x :: xs

public export
Context : (kind : Type) -> (types : List kind) -> Type
Context kind = DList kind Item

export
extend : (ctxt  : Context kind types)
      -> (label : String)
      -> (type  : kind)
               -> Context kind (types += type)
extend ctxt label type
  = I label type :: ctxt

export
(+=) : (ctxt  : Context kind types)
    -> (label : String)
    -> (type  : kind)
             -> Context kind (types += type)
(+=) = extend

||| A quantifier over the context that the given predicate holds.
|||
||| This is modelled after De Bruijn indices, and the underlying
||| quantifier is `Any`.
|||
public export
data Exists : (kind : Type)
           -> (pred  : (type : kind) -> Type)
           -> (key   : String)
           -> {types : List kind}
           -> (ctxt  : Context kind types)
                    -> Type
  where
    E : {ctxt : Context kind types}
     -> {pred : (type : kind) -> Type}
     -> (type : kind)
     -> (item : Item type)
     -> (prf  : pred type)
     -> {loc  : Nat}
     -> (locC : HoldsAtIndex kind Item (Holds kind pred key) ctxt loc)
     -> (locN : AtIndex type types loc)
             -> Exists kind pred key ctxt

export
deBruijn : {ctxt : Context kind types}
        -> (prf  : Exists kind pred key ctxt)
                -> (type ** DPair Nat (AtIndex type types))
deBruijn (E type item prf locC locN)
  = (type ** _ ** locN)

namespace Exists
  public export
  data Error type = NotFound
                  | NotSatisfied type

isEmpty : Exists kind pred key [] -> Void
isEmpty (E _ _ _ (Here x) _) impossible
isEmpty (E _ _ _ (There contra later) _) impossible

notLater : (Holds  kind pred key  h      -> Void)
        -> (Exists kind pred key       t -> Void)
        ->  Exists kind pred key (h :: t)
        -> Void
notLater f g (E type item prf (Here x) locN) = f x
notLater f g (E type item prf (There contra later) (There x)) = g (E type item prf later x)

export
exists : {kind  : Type}
      -> {types : List kind}
      -> {pred  : (type : kind) -> Type}
      -> (func  : (type : kind) -> DecInfo err (pred type))
      -> (key   : String)
      -> (ctxt  : Context kind types)
               -> DecInfo (Exists.Error err)
                          (Exists kind pred key ctxt)

exists f _ []
  = No NotFound
       isEmpty
exists f key (head :: tail) with (holds f key head)
  exists f key ((I str x) :: tail) | (Yes (H prfK prf))
    = Yes (E _ (I str x) prf (Here (H prfK prf)) Here)

  exists f key (head :: tail) | (No msg contra) with (exists f key tail)
    exists f key (head :: tail) | (No msg contra) | (Yes (E type item prf locC locN))
      = Yes (E type item prf (There contra locC) (There locN))

    -- [ Note ]
    --
    -- we need to ensure that the 'correct' error message has been satisfied.
    exists f key (head :: tail) | (No (NotSatisfied x) contra) | (No msgR contraR)
      = No (NotSatisfied x)
           (notLater contra contraR)
    exists f key (head :: tail) | (No (WrongName x y) contra) | (No msgR contraR)
      = No msgR
           (notLater contra contraR)

namespace Lookup

  public export
  IsBound : {kind  : Type}
         -> {types : List kind}
         -> (key   : String)
         -> (ctxt  : Context kind types)
                  -> Type
  IsBound {kind} str ctxt
    = Exists kind Singleton
                str
                ctxt

  single : (item : kind)
                -> DecInfo () (Singleton item)
  single item = Yes (Val item)

  export
  lookup : {kind  : Type}
        -> {types : List kind}
        -> (str   : String)
        -> (ctxt  : Context kind types)
                 -> DecInfo (Exists.Error ())
                            (IsBound str ctxt)
  lookup = exists single

-- [ EOF ]


{--
Copyright 2021 Joel Berkeley

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

    http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
--}
||| This module contains the `Tensor` object, an array of values of arbitrary type, along with a
||| number of functions operating on numeric `Tensor`s.
module Tensor

import Data.Vect
import Data.Vect.Elem
import Decidable.Equality

import Error
import public Primitive
import public Types
import Util
import XLA.Client.XlaBuilder
import XLA.Literal

----------------------------- core definitions ----------------------------

||| A `Tensor` is a symbolic value, which may refer to either to a scalar value or array of values,
||| though the runtime representation will likely contain more than its value, and will depend on
||| the specific backend.
|||
||| @shape The `Tensor` shape.
||| @dtype The element type.
export
data Tensor : (0 shape : Shape {rank}) -> (0 dtype : Type) -> Type where
  MkTensor : RawTensor -> Tensor shape dtype

||| Construct a `Tensor` from `Array` data.
export
const : Primitive dtype => {shape : _} -> Array shape {dtype} -> Tensor shape dtype
const xs = MkTensor $ const {rank=length shape} (rewrite lengthCorrect shape in xs)

||| Evaluate a `Tensor`, returning its value as an `Array`.
export
eval : Primitive dtype => {shape : _} -> Tensor shape dtype -> IO $ Array shape {dtype}
eval (MkTensor raw) = eval raw

||| Return a string representation of an unevaluated `Tensor`, detailing all enqueued operations.
||| Useful for debugging.
export
toString : Tensor shape dtype -> IO String
toString (MkTensor raw) = toString raw

||| A mutable tensor. That is, a tensor that can be modified in-place.
|||
||| We can do this in Idris with linearity. Linearity is offered by quantitative type theory*, which
||| allows us to guarantee that a value is used at run time either never (erased), once (linear), or
||| more. In-place mutation traditionally suffers from the problem that you have to reason about
||| what state a value is in in a series of computations: whether it has been mutated and how. For
||| example, in the following pseudo-code,
|||
||| ```
||| a = 1
||| a += 1
||| b = f(a)
||| ```
|||
||| We have to be aware of whether `a` was modified between its initialization and its use in the
||| calculation of `b`. This problem is solved by simply defining a new variable, as
|||
||| ```
||| a = 1
||| a' = a + 1
||| b = f(a')
||| ```
|||
||| but this doesn't provide the same performance benefits of in-place mutation. The conundrum is
||| (at least largely) solved with linear types, because you can require that the action of mutating
||| a value "uses it up" such that the previous reference to it cannot be used any more. In the
||| first example, the mutation `a += 1` would use up `a` and we wouldn't be able to use it in the
||| construction of `b`, so the problem no longer exists.
|||
||| In order to ensure `Variable` is only used as a linear type, it is accessible only via the
||| function `var`.
|||
||| *See http://www.type-driven.org.uk/edwinb
|||
||| @shape The `Variable` shape.
||| @dtype The element type.
export
data Variable : (0 shape : Shape) -> (0 dtype : Type) -> Type where
  MkVariable : Primitive dtype => Array shape {dtype=dtype} -> Variable shape dtype

||| Provides access to a linear `Variable` with initial contents `arr`. For example:
|||
||| ```idris
||| addOne : (1 v : Variable [] Double) -> Variable [] Double
||| addOne v = v += const {shape=[]} 1
|||
||| three : Tensor [] Double
||| three = var 2.0 $ \v => freeze $ addOne v
||| ```
|||
||| @arr The initial contents of the `Variable`.
||| @f A function which uses the `Variable`. The return value of `f` is returned by `var`.
var : Primitive dtype =>
      Array shape {dtype=dtype} -> (1 f : (1 v : Variable shape dtype) -> a) -> a
var arr f = f (MkVariable arr)

||| Convert a `Variable` to a `Tensor`.
freeze : (1 _ : Variable shape dtype) -> Tensor shape dtype

----------------------------- structural operations ----------------------------

||| Get the `idx`-th row from a tensor. For example, `index 1 $ const [[1, 2], [3, 4], [5, 6]]`
||| is equivalent to `const [3, 4]`.
|||
||| @idx The row to fetch.
export
index : (idx : Fin d) -> Tensor (d :: ds) dtype -> Tensor ds dtype

||| Split a `Tensor` along the first axis at the specified index. For example,
||| `split 1 const [[1, 2], [3, 4], [5, 6]]` is equivalent to
||| `(const [[1, 2]], const [[3, 4], [5, 6]])`.
|||
||| @idx The index of the row at which to split the `Tensor`. The row with index `idx` in
|||   the input `Tensor` will appear in the result as the first row in the second `Tensor`.
export
split : (idx : Nat) -> Tensor ((idx + rest) :: tl) dtype
  -> (Tensor (idx :: tl) dtype, Tensor (rest :: tl) dtype)

||| Concatenate two `Tensor`s along their first axis. For example,
||| `concat (const [[1, 2], [3, 4]]) (const [[5, 6]])` is equivalent to
||| `const [[1, 2], [3, 4], [5, 6]]`.
export
concat : Tensor (n :: tl) dtype -> Tensor (m :: tl) dtype -> Tensor ((n + m) :: tl) dtype

||| Add a dimension of length one at the specified `axis`. The new dimension will be at the
||| specified axis in the new `Tensor` (as opposed to the original `Tensor`). For example,
||| `expand 1 $ const [[1, 2], [3, 4], [5, 6]]` is equivalent to
||| `const [[[1, 2]], [[3, 4]], [[5, 6]]]`.
export
expand :
  (axis : Fin (S rank)) -> Tensor {rank=rank} shape dtype -> Tensor (insertAt axis 1 shape) dtype

||| Tranpose the last two axes of a tensor. For example, `(const [[1, 2], [3, 4]]).T` is equivalent
||| to `const [[1, 3], [2, 4]]`.
export
(.T) : forall shape, dtype . Tensor shape dtype ->
       let leading = init (init shape)
           m = last (init shape)
           n = last shape
        in Tensor (leading ++ [n, m]) dtype

||| Cast the tensor elements to a new data type.
export
cast_dtype : Cast dtype dtype' => Tensor shape dtype -> Tensor shape dtype'

||| Construct a diagonal tensor from the specified value, where all off-diagonal elements are zero.
||| For example, `the (Tensor [2, 2] Double) (diag 3)` is equivalent to
||| `const [[3.0, 0.0], [0.0, 3.0]]`.
export
diag : Num dtype => Tensor [] dtype -> Tensor [n, n] dtype

||| A `DimBroadcastable from to` proves that a dimension of size `from` can be broadcast to a
||| dimension of size `to`.
public export
data DimBroadcastable : (0 from : Nat) -> (0 to : Nat) -> Type where
  ||| Proof that any dimension can be broadcast to itself. For example in shapes `[2, 3]` to
  ||| `[2, 3]`.
  Same : DimBroadcastable x x

  ||| Proof that a dimension of length one can be broadcast to any size. For example in shapes
  ||| `[2, 1]` to `[2, 3]`
  Stack : DimBroadcastable 1 _

  ||| Proof that any dimension can be broadcast to zero. For example in shapes `[2, 3]` to `[2, 0]`.
  Zero : DimBroadcastable _ 0

namespace Broadcastable
  ||| A `Broadcastable from to` constitutes proof that the shape `from` can be broadcast to the
  ||| shape `to`.
  public export
  data Broadcastable : (0 from : Shape) -> (0 to : Shape) -> Type where
    ||| Proof that a shape can be broadcast to itself. For example:
    |||
    ||| [] to []
    ||| [3, 4] to [3, 4]
    |||
    ||| Implementation note: we could have used `Broadcast [] []`, which would have resulted in more
    ||| atomic constructors for `Broadcastable`, but the author guesses that this implementation helps
    ||| the type checker avoid applications of `Match`.
    Same : Broadcastable x x

    ||| Proof that a dimension of size `f` can be broadcast to size `t` if these dimensions
    ||| are `DimBroadcastable f t`. For example:
    |||
    ||| [2, 3] to [2, 3]
    ||| [2, 1] to [2, 3]
    ||| [2, 1] to [2, 0]
    Match : {0 from, to : Shape {rank=r}}
            -> {auto 0 _ : DimBroadcastable f t}
            -> Broadcastable from to
            -> Broadcastable (f :: from) (t :: to)

    ||| Proof that broadcasting can add outer dimensions i.e. nesting. For example:
    |||
    ||| [3] to [1, 3]
    ||| [3] to [5, 3]
    Nest : Broadcastable f t -> Broadcastable f (_ :: t)

empty : Primitive dtype => {shape : Shape} -> {auto isEmpty : Elem 0 shape} -> Tensor shape dtype
empty = const (emptyArray shape) where
  emptyArray : (shape : _) -> {auto isEmpty : Elem Z shape} -> Array shape
  emptyArray {isEmpty = Here} (0 :: _) = []
  emptyArray {isEmpty = (There _)} (d :: ds) = replicate d (emptyArray ds)

||| Broadcast a `Tensor` to a new compatible shape. For example,
|||
||| ```idris
||| x : Tensor [2, 3] Double
||| x = broadcast (const [4, 5, 6])
||| ```
|||
||| is equivalent to
|||
||| ```idris
||| x : Tensor [2, 3] Double
||| x = const [[4, 5, 6], [4, 5, 6]]
||| ```
export
broadcast : Primitive dtype => {from : _} -> {to : _} -> {auto prf : Broadcastable from to}
  -> Tensor from dtype -> Tensor to dtype
broadcast xs = case (isElem 0 to, toList from == toList to) of
  (Yes _, False) => empty
  _ =>
    let from_prf = lengthCorrect from
        to_prf = lengthCorrect to in
        rewrite sym to_prf in impl {fr=length from} {tr=length to} {tt=length to} []
          (rewrite to_prf in to) (rewrite from_prf in xs)
          {prf=rewrite to_prf in rewrite from_prf in prf}

    where
    impl : {fr, tr : _} -> {from : Shape {rank=fr}} -> {to : Shape {rank=tr}}
      -> {tl, tt : _} -> (to_leading : Vect tl Nat) -> (to_trailing : Vect tt Nat)
      -> {auto prf : Broadcastable from to_trailing} -> Tensor from dtype -> Tensor to dtype
    impl to_leading _ {prf=Same} (MkTensor raw) =
      MkTensor $ if (length to_leading == 0) then raw else broadcast raw to_leading
    impl {fr = (S r)} to_leading (th' :: tt') {prf=(Match _)} (MkTensor raw) =
      MkTensor $ broadcast (broadcastInDim raw (th' :: tt') (range (S r))) to_leading
    impl to_leading (th' :: tt') {prf=(Nest _)} xs = impl (to_leading ++ [th']) tt' xs

scalarToAnyOk : (to : Shape) -> Broadcastable [] to
scalarToAnyOk [] = Same
scalarToAnyOk (_ :: xs) = Nest (scalarToAnyOk xs)

namespace Squeezable
  ||| A `Squeezable from to` constitutes proof that the shape `from` can be squeezed to the
  ||| shape `to`. Squeezing is the process of removing any number of dimensions of length one.
  public export
  data Squeezable : (0 from : Shape) -> (0 to : Shape) -> Type where
    ||| Proof that a shape can be squeezed to itself. For example:
    |||
    ||| [] to []
    ||| [3, 4] to [3, 4]
    Same : Squeezable x x

    ||| Proof that any dimensions (including those of length 1) can be preserved in the process of
    ||| squeezing. For example:
    |||
    ||| ...
    Match : Squeezable from to -> Squeezable (x :: from) (x :: to)

    ||| Proof that any dimensions of length one can be squeezed out. For example:
    |||
    ||| [1, 3, 1, 1, 4] to [3, 4]
    Nest : Squeezable from to -> Squeezable (1 :: from) to

||| Remove dimensions of length one from a `Tensor` such that it has the desired shape. For example:
|||
||| ```idris
||| x : Tensor [2, 1, 3, 1] Double
||| x = const [[[[4], [5], [6]]], [[[7], [8], [9]]]]
|||
||| y : Tensor [2, 1, 3] Double
||| y = squeeze x
||| ```
|||
||| is equivalent to
|||
||| ```idris
||| y : Tensor [2, 1, 3] Double
||| y = const [[[4, 5, 6]], [[7, 8, 9]]]
||| ```
export
squeeze : {auto 0 _ : Squeezable from to} -> Tensor from dtype -> Tensor to dtype

||| A `Tensor` where every element has the specified value. For example,
|||
||| ```idris
||| fives : Tensor [2, 3] Int
||| fives = fill 5
||| ```
||| is equivalent to
||| ```idris
||| fives : Tensor [2, 3] Int
||| fives = const [[5, 5, 5], [5, 5, 5]]
||| ```
export
fill : Primitive dtype => {shape : _} -> dtype -> Tensor shape dtype
fill = broadcast {prf=scalarToAnyOk shape} . const

----------------------------- numeric operations ----------------------------

infix 6 ==#, /=#

||| Element-wise equality. For example, `const [1, 2] ==# const [1, 3]` is equivalent to
||| `const [True, False]`.
export
(==#) : Eq dtype => Tensor shape dtype -> Tensor shape dtype -> Tensor shape Bool
(MkTensor l) ==# (MkTensor r) = MkTensor (eq l r)

||| Element-wise inequality. For example, `const [1, 2] /=# const [1, 3]` is equivalent to
||| `const [False, True]`.
export
(/=#) : Eq dtype => Tensor shape dtype -> Tensor shape dtype -> Tensor shape Bool
(MkTensor l) /=# (MkTensor r) = MkTensor (ne l r)

infix 6 <#, >#, <=#, >=#

||| Element-wise less than. For example, `const [1, 2, 3] <# const [2, 2, 2]` is equivalent to
||| `const [True, False, False]`.
export
(<#) : Ord dtype => Tensor shape dtype -> Tensor shape dtype -> Tensor shape Bool
(MkTensor l) <# (MkTensor r) = MkTensor (lt l r)

||| Element-wise greater than. For example, `const [1, 2, 3] ># const [2, 2, 2]` is equivalent to
||| `const [False, False, True]`.
export
(>#) : Ord dtype => Tensor shape dtype -> Tensor shape dtype -> Tensor shape Bool
(MkTensor l) ># (MkTensor r) = MkTensor (gt l r)

||| Element-wise less than or equal. For example, `const [1, 2, 3] <=# const [2, 2, 2]` is
||| equivalent to `const [True, True, False]`.
export
(<=#) : Ord dtype => Tensor shape dtype -> Tensor shape dtype -> Tensor shape Bool
(MkTensor l) <=# (MkTensor r) = MkTensor (le l r)

||| Element-wise greater than or equal. For example, `const [1, 2, 3] >=# const [2, 2, 2]` is
||| equivalent to `const [False, True, True]`.
export
(>=#) : Ord dtype => Tensor shape dtype -> Tensor shape dtype -> Tensor shape Bool
(MkTensor l) >=# (MkTensor r) = MkTensor (ge l r)

-- see https://www.python.org/dev/peps/pep-0465/#precedence-and-associativity
infixl 9 @@

||| Matrix multiplication. The tensors are contracted along the last axis of the first tensor and
||| the first axis of the last tensor. For example:
|||
||| ```idris
||| x : Tensor [2, 3] Double
||| x = const [[-1, -2, -3], [0, 1, 2]]
|||
||| y : Tensor [3, 1] Double
||| y = const [[4, 0, 5]]
|||
||| z : Tensor [2, 1] Double
||| z = x @@ y
||| ```
|||
||| is equivalent to
|||
||| ```idris
||| z : Tensor [2, 1] Double
||| z = const [-19, 10]
||| ```
export
(@@) : Num dtype => Tensor l dtype -> Tensor (S n :: tail') dtype ->
       {auto 0 _ : last l = S n} -> Tensor (init l ++ tail') dtype

||| Element-wise addition. For example, `const [1, 2] + const [3, 4]` is equivalent to
||| `const [4, 6]`.
export
(+) : Num dtype => Tensor shape dtype -> Tensor shape dtype -> Tensor shape dtype
(MkTensor ll_raw) + (MkTensor rr_raw) = MkTensor (add ll_raw rr_raw)

||| Element-wise negation. For example, `- const [1, -2]` is equivalent to `const [-1, 2]`.
export
negate : Neg dtype => Tensor shape dtype -> Tensor shape dtype

||| Element-wise subtraction. For example, `const [3, 4] - const [4, 2]` is equivalent to
||| `const [-1, 2]`.
export
(-) : Neg dtype => Tensor shape dtype -> Tensor shape dtype -> Tensor shape dtype

infixl 9 *#, /#

||| Elementwise multiplication. For example, `const [2, 3] *# const [4, 5]` is equivalent to
||| `const [8, 15]`.
export
(*#) : Num dtype => Tensor shape dtype -> Tensor shape dtype -> Tensor shape dtype
(MkTensor l) *# (MkTensor r) = MkTensor (mul l r)

||| Multiplication by a constant. For example, `const 2 * const [3, 5]` is equivalent to
||| `const [6, 10]`.
export
(*) : (Primitive dtype, Num dtype) => Tensor [] dtype -> {shape : _} -> Tensor shape dtype
      -> Tensor shape dtype
l * r = (broadcast {prf=scalarToAnyOk shape} l) *# r

||| Elementwise floating point division. For example, `const [2, 3] /# const [4, 5]` is equivalent to
||| `const [0.5, 0.6]`.
export
(/#) : Fractional dtype => Tensor shape dtype -> Tensor shape dtype -> Tensor shape dtype

||| Floating point division by a constant. For example, `const [3.4, -5.6] / const 2` is equivalent
||| to `const [1.7, -2.8]`.
export
(/) : Fractional dtype => Tensor shape dtype -> Tensor [] dtype -> Tensor shape dtype

infixr 9 ^

-- todo we don't support complex yet
||| Each element in `base` raised to the power of the corresponding element in `exponent`.
||| example, `const [2, 25, -9] ^ const [3, -0.5, 0.5]` is equivalent to `const [8, 0.2, 3i]`.
|||
||| Note: The first root is used.
export
(^) : Num dtype => Tensor shape dtype -> Tensor shape dtype -> Tensor shape dtype

-- todo
||| The element-wise natural exponential.
export
exp : Tensor shape Double -> Tensor shape Double

infix 8 +=
infix 8 -=
infix 8 *=
infix 8 //=

||| Element-wise in-place addition. It is in-place in the sense that the value in memory is mutated
||| in-place. However, since the function is linear its `Variable`, you must still use the result to
||| get the updated value. For example:
|||
||| ```idris
||| addOne : (1 v : Variable [] Double) -> Variable [] Double
||| addOne v = v += const {shape=[]} 1
||| ```
|||
||| Other than the fact that it works on a `Variable`, and mutates the value in-place, it works
||| exactly like `(+)` on a `Tensor`.
export
(+=) : Num dtype => (1 v : Variable shape dtype) -> Tensor shape dtype -> Variable shape dtype

||| Element-wise in-place subtraction. See `(+=)` and `(+)` for details.
export
(-=) : Neg dtype => (1 v : Variable shape dtype) -> Tensor shape dtype -> Variable shape dtype

||| Element-wise in-place multiplication. See `(+=)` and `(*)` for details.
export
(*=) : Num dtype => (1 v : Variable shape dtype) -> Tensor shape dtype -> Variable shape dtype

||| Element-wise in-place division. See `(+=)` and `(/)` for details.
export
(//=) : Fractional dtype =>
        (1 v : Variable shape dtype) -> Tensor shape dtype -> Variable shape dtype

-- todo
||| The element-wise natural logarithm.
export
log : Tensor shape Double -> Tensor shape Double

||| Reduce a `Tensor` along the specified `axis` to the smallest element along that axis, removing
||| the axis in the process. For example, `reduce_min 1 $ const [[-1, 5, 10], [4, 5, 6]]` is
||| equivalent to `const [-1, 5, 6]`.
export
reduce_min : Num dtype => (axis : Fin (S r)) -> Tensor {rank=S r} shape dtype ->
  {auto 0 _ : IsSucc $ index axis shape} -> Tensor (deleteAt axis shape) dtype

||| Reduce a `Tensor` along the specified `axis` to the sum of its components, removing the axis in
||| the process. For example, `reduce_sum 1 $ const [[-1, 2, 3], [4, 5, -6]]` is equivalent to
||| `const [3, 7, -3]`.
export
reduce_sum : Num dtype => (axis : Fin (S r)) -> Tensor {rank=S r} shape dtype ->
  {auto 0 _ : IsSucc $ index axis shape} ->  Tensor (deleteAt axis shape) dtype

---------------------------- other ----------------------------------

||| The determinant of a tensor (with respect to the last two axes). For example,
||| `det $ const [[1, 2], [3, 4]]` is equivalent to `const -2`.
export
det : forall shape, dtype . Neg dtype => Tensor shape dtype ->
      let leading = init (init shape)
          m = last (init shape)
          n = last shape
       in {auto 0 isSquare : m = n} -> {auto 0 nonEmpty : IsSucc m} -> Tensor leading dtype

||| Cholesky decomposition. Finds the lower triangular matrix `L` from `X` s.t. `X = L @@ L.T`.
export
cholesky : Tensor [S n, S n] dtype -> Tensor [S n, S n] dtype

infix 9 \\

||| Find `Y` from `A` and `X` s.t. `X = AY` where `A` is a lower triangular matrix.
export
(\\) : Tensor [n, n] dtype -> Tensor (n :: tl) dtype -> Tensor (n :: tl) dtype

||| Indicates an operation was impossible (at the attempted precision) due to a matrix being
||| singular.
export
data SingularMatrixError = MkSingularMatrixError String

export
Error SingularMatrixError where
  format (MkSingularMatrixError msg) = msg

||| The inverse of a matrix. For example, `inverse $ const [[1, 2], [3, 4]]` is equivalent to
||| `const [[-2, -1], [-1.5, -0.5]]`.
export
inverse : Tensor [S n, S n] Double -> Either SingularMatrixError $ Tensor [S n, S n] Double

||| The product of all elements along the diagonal of a matrix. For example,
||| `trace_product $ const [[2, 3], [4, 5]]` is equivalent to `const 10`.
export
trace_product : Num dtype => Tensor [S n, S n] dtype -> Tensor [] dtype

||| Sum the elements along the diagonal of the input.
export
trace : Num dtype => Tensor [S n, S n] dtype -> Tensor [] dtype


%default partial

foo : Maybe a -> a
foo (Just x) = x

data Vect : ? -> Type -> Type where
     Nil : Vect Z a
     (::) : a -> Vect k a -> Vect (S k) a

data Fin : Nat -> Type where
     FZ : Fin (S k)
     FS : Fin k -> Fin (S k)

lookup : Fin n -> Vect n a -> a
lookup FZ (x :: xs) = x
lookup (FS k) (x :: xs) = lookup k xs

lookup' : Fin n -> Vect n a -> a
lookup' (FS k) (x :: xs) = lookup' k xs

lookup'' : Fin n -> Vect n a -> a
lookup'' n xs = lookup' n xs

main : IO ()
main = do let x = foo Nothing
          printLn (the Int x)


%default total

interface C a (f : Bool -> Bool) | a where {}
implementation C Int Bool.not where {}

foo : C Int g => {auto pf : g True = False} -> Unit
foo = ()

main : IO ()
main = printLn $ foo -- {pf = Refl}


module Main

interface Symantics (repr : Type -> Type) where
  int : Int -> repr Int
  bool : Bool -> repr Bool
  string : String -> repr String
  nil : repr (List a)
  not : repr Bool -> repr Bool
  (==) : Eq a => repr a -> repr a -> repr Bool
  (*) : Num a => repr a -> repr a -> repr a
  lam : (repr a -> repr b) -> repr (a -> b)
  app : repr (a -> b) -> repr a -> repr b
  foreach : Lazy (repr (List a)) -> (repr a -> repr (List b)) -> repr (List b)
  where' : repr Bool -> Lazy (repr (List a)) -> repr (List a)
  yield : repr a -> repr (List a)
  union_all : repr (List a) -> repr (List a) -> repr (List a)

record Product where
  constructor MkProduct
  pid : Int
  name : String
  price : Int

record Order where
  constructor MkOrder
  oid : Int
  opid : Int
  qty : Int

record Sale where
  constructor MkSale
  spid : Int
  sname : String
  amount : Int

interface Symantics repr => SymSchema (repr : Type -> Type) where
  product : repr Int -> repr String -> repr Int -> repr Product
  pid : repr Product -> repr Int
  name : repr Product ->  repr String
  price : repr Product -> repr Int
  products : Lazy (repr (List Product))

  order : repr Int -> repr Int -> repr Int -> repr Order
  oid : repr Order -> repr Int
  opid : repr Order -> repr Int
  qty : repr Order -> repr Int
  orders : Lazy (repr (List Order))

  sale : repr Int -> repr String -> repr Int -> repr Sale

listFive : Symantics r => r (List Int)
listFive = yield (int 5)

-- products
tablet : SymSchema r => r Product
tablet = product (int 1) (string "Tablet") (int 500)
laptop : SymSchema r => r Product
laptop = product (int 2) (string "Laptop") (int 1000)
desktop : SymSchema r => r Product
desktop = product (int 3) (string "Desktop") (int 1000)
router : SymSchema r => r Product
router = product (int 4) (string "Router") (int 150)
hdd : SymSchema r => r Product
hdd = product (int 5) (string "HDD") (int 100)
ssd : SymSchema r => r Product
ssd = product (int 6) (string "SSD") (int 500)

-- orders
o1 : SymSchema r => r Order
o1 = order (int 1) (int 1) (int 5)
o2 : SymSchema r => r Order
o2 = order (int 1) (int 2) (int 5)
o3 : SymSchema r => r Order
o3 = order (int 1) (int 4) (int 2)
o4 : SymSchema r => r Order
o4 = order (int 2) (int 5) (int 10)
o5 : SymSchema r => r Order
o5 = order (int 2) (int 6) (int 20)
o6 : SymSchema r => r Order
o6 = order (int 3) (int 2) (int 50)

data Evaluator a = R a

eval : Evaluator a -> a
eval (R a) = a

Symantics Evaluator where
  int = R
  bool = R
  string = R
  not (R b) = R (not b)
  nil = R []
  (==) (R a) (R b) = R (a == b)
  (*) (R a) (R b) = R (a * b)
  lam f = R (\a => eval (f (R a)))
  app (R f) (R a) = R (f a)
  foreach t f =
    case eval t of
      []        => R []
      (x :: xs) => R (eval (f (R x)) ++ (eval (foreach (R xs) f)))
  where' (R b) r = if b then r else R []
  yield (R x) = R [x]
  union_all (R as) (R bs) = R (as ++ bs)

Symantics Evaluator => SymSchema Evaluator where
  product (R pid) (R name) (R price) = R (MkProduct pid name price)
  pid (R p) = R (pid p)
  name (R p) = R (name p)
  price (R p) = R (price p)
  products = R (map eval [tablet, laptop, desktop, router, hdd, ssd]) -- yield tablet `union_all` yield laptop

  order (R oid) (R opid) (R qty) = R (MkOrder oid opid qty)
  oid (R o) = R (oid o)
  opid (R o) = R (opid o)
  qty (R o) = R (qty o)
  orders = R (map eval [o1, o2, o3, o4, o5, o6])

  sale (R spid) (R sname) (R amount) = R (MkSale spid sname amount)

-- eval (foreach products (\p => yield (pid p)) `union_all` foreach orders (\o => yield (opid o)))

-- Q1
q1 : SymSchema r => r Int -> r (List Order)
q1 xoid = foreach orders $ \o =>
            where' (oid o == xoid) $
              yield o

q1_2 : SymSchema r => r (List Order)
q1_2 = q1 (int 2) -- I'm not using `app` and `lam` anywhere. Is that a problem?

-- eval q1_2

q2 : SymSchema r => r Order -> r (List Sale)
q2 o = foreach products $ \p =>
         where' (not (not (pid p == opid o))) $
           yield $ sale (pid p) (name p) (price p * qty o)

-- eval (q2 (order (int 2) (int 5) (int 10)))
q3 : SymSchema r => r Int -> r (List Sale)
q3 x = foreach (q1 x) $ \y =>
         q2 y
-- Still no app and lam... Oleg et. al. use app, but no lam either

-- eval (q3 (int 2))

data Printer a = P String

print : Printer a -> String
print (P a) = a

Symantics Printer where
  int i = P (show i)
  bool b = P (show b)
  string s = P s
  not (P b) = P ("(NOT " ++ b ++ ")")
  nil = P "[]"
  (==) (P a) (P b) = P (a ++ " == " ++ b)
  (*) (P a) (P b) = P ("(" ++ a ++ " * " ++ b ++ ")")
  lam f = P "lam"
  app (P f) (P a) = P "app"
  foreach t f =
    let ts : String = print t
        fs : String = print (f (P "$arg"))
    in P ("FOREACH (" ++ ts ++ ") " ++ fs)
  where' (P b) r = P ("WHERE " ++ b ++ " " ++ (print r))
  yield (P x) = P ("YIELD " ++ x)
  union_all (P as) (P bs) = P (as ++ " UNION ALL " ++ bs)

Symantics Printer => SymSchema Printer where
  product _ _ _ = P "product"
  pid (P x) = P (x ++ ".pid")
  name (P x) = P (x ++ ".name")
  price (P x) = P (x ++ ".price")
  products = P "products"
  order x y z = P "order"
  oid (P x) = P (x ++ ".oid")
  opid (P x) = P (x ++ ".pid")
  qty (P x) = P (x ++ ".qty")
  orders = P "orders"
  sale x y z = P $ "(MkSale " ++ print x ++ " " ++ print y ++ " " ++ print z ++ ")"

-- λΠ> print (q3 (int 2))
-- "FOREACH (FOREACH (orders) WHERE $arg.oid == 2 YIELD $arg) FOREACH (products) WHERE $arg.pid == $arg.pid YIELD (MkSale $arg.pid $arg.name ($arg.price * $arg.qty))" : String

data ConstantFolder : (repr : Type -> Type) -> (a : Type) -> Type where
  Empty : ConstantFolder repr (List a)
  Unknown : (repr a) -> ConstantFolder repr a

dyn : Symantics repr => ConstantFolder repr a -> repr a
dyn Empty = nil
dyn (Unknown x) = x

Symantics r => Symantics (ConstantFolder r) where
  nil = Empty
  union_all Empty y = y
  union_all (Unknown x) y = Unknown (union_all x (dyn y))
  -- boilerplate
  int x = Unknown (int x)
  bool x = Unknown (bool x)
  string x = Unknown (string x)
  not b = Unknown (not (dyn b))
  lam f = Unknown (lam (\x => dyn (f (Unknown x))))
  app x y = Unknown (app (dyn x) (dyn y))
  foreach t f = Unknown $ foreach (Delay (dyn t)) (\x => dyn (f (Unknown x)))
  where' x y = Unknown (where' (dyn x) (dyn y))
  yield x = Unknown (yield (dyn x))
  (==) x y = Unknown (dyn x == dyn y)
  (*) x y = Unknown (dyn x * dyn y)

SymSchema r => SymSchema (ConstantFolder r) where
-- (Symantics (ConstantFolder r), SymSchema r) => SymSchema (ConstantFolder r) where
  product x y z = Unknown $ product (dyn x) (dyn y) (dyn z)
  pid = pid
  name = name
  price = price
  products = products
  order = order
  oid = oid
  opid = opid
  qty = qty
  orders = Unknown $ Force orders -- not sure I like this Force
  sale = sale

cfp' : ConstantFolder Printer (List Int)
cfp' = union_all nil (yield (int 2))

-- print (dyn (union_all nil (yield (int 2))))

-- From http://okmij.org/ftp/tagless-final/course/RR.hs
--
-- {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}

-- -- * Reflection-Reification pair

-- module RR where

-- class RR t repr where
--   fwd :: repr a -> t repr a
--   bwd :: t repr a -> repr a

--   map1 :: (repr a -> repr b) -> (t repr a -> t repr b)
--   map1 f = fwd . f . bwd

--   map2 :: (repr a -> repr b -> repr c) ->
--           (t repr a -> t repr b -> t repr c)
--   map2 f e1 e2 = fwd (f (bwd e1) (bwd e2))

-- -- * fwd is generally not surjective and bwd is not injective
-- -- * bwd . fwd == id,  fwd . bwd /= id

-- -- * QUIZ
-- -- * map1 looks like fmap of a Functor. Can it be defined or related
-- -- * to Functor?

interface RR (t : (Type -> Type) -> Type -> Type) (repr : Type -> Type) where
  fwd : repr a -> t repr a
  bwd : t repr a -> repr a

  map1 : (repr a -> repr b) -> (t repr a -> t repr b)
  map1 f = fwd . f . bwd

  map2 : (repr a -> repr b -> repr c) -> (t repr a -> t repr b -> t repr c)
  map2 f e1 e2 = fwd (f (bwd e1) (bwd e2))

-- print (q_3 (int 2))

data N2N : (repr : Type -> Type) -> (a : Type) -> Type where
  Unk : repr a -> N2N repr a           -- no annotation
  Neg : repr Bool -> N2N repr Bool     -- it is a negation

-- instance Symantics repr => RR N2N repr where
--   bwd (Unk e) = e
--   bwd (Neg x) = neg x

--   fwd = Unk

Symantics repr => RR N2N repr where
  bwd (Unk e) = e
  bwd (Neg x) = not x

  fwd = Unk

-- instance Symantics repr => Symantics (N2N repr) where
--   lit = fwd . lit

--   neg (Unk e) = Neg e                   -- we statically know we negated
--   neg (Neg x) = Unk x

--   -- and e1 e2 = Unk $ and (bwd e1) (bwd e2)
--   and = map2 and
--   or  = map2 or

Symantics repr => Symantics (N2N repr) where
  bool = fwd . bool

  not (Unk e) = Neg e                   -- we statically know we negated
  not (Neg x) = Unk x

  int = fwd . int
  string = fwd . string
  (==) = map2 (==)
  (*) = map2 (*)
  nil = fwd nil
  lam f = fwd (lam (\x => bwd (f (fwd x))))
  app = map2 app
  foreach x f = fwd $ foreach (bwd x) (\x => bwd (f (fwd x)))
  where' x y = fwd $ where' (bwd x) (bwd y)
  yield = map1 yield -- not sure..
  union_all = map2 union_all

-- instance SymInput repr => SymInput (N2N repr) where
--   wireX = fwd wireX
--   wireY = fwd wireY
--   wireZ = fwd wireZ

SymSchema r => SymSchema (N2N r) where
  product x y z = fwd $ product (bwd x) (bwd y) (bwd z)
  pid = map1 pid
  name = map1 name
  price = map1 price
  products = fwd $ Force products
  order x y z = fwd $ order (bwd x) (bwd y) (bwd z)
  oid = map1 oid
  opid = map1 opid
  qty = map1 qty
  orders = fwd $ Force orders
  sale x y z = fwd $ sale (bwd x) (bwd y) (bwd z)

-- -- * Observe the result
-- -- A type-specific version of bwd
-- obsN2N :: Symantics repr => N2N repr a -> repr a
-- obsN2N = bwd
obsN2N : Symantics repr => N2N repr a -> repr a
obsN2N = bwd

-- print (obsN2N (q3 (int 2)))


-- exercises in "Type-Driven Development with Idris"
-- chapter 14

-- check that all functions are total
%default total

--
-- section 14.2
-- see Security.idr
-- see VendingMachine.idr
--


module Sub07Apply108x27

import ProofColDivSeqBase
import ProofColDivSeqPostulate
import ProofColDivSeqPostuProof

%default total
-- %language ElabReflection

-- 3(36x+9) --F[5,-2]->C[4,-4]--> 3(32x+7)
export
apply108x27 : (Not . P) (S (S (S (S (plus (plus (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))
                                                (S (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))))
                                          (S (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))))))))
  -> (m : Nat **
        (LTE (S m)
             (S (S (S (S (plus (plus (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))
                                     (S (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))))
                               (S (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o)))))))))),
         (Not . P) m))
apply108x27 {o} col = ((S (S (S (S (S (S (S (plus (plus (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o))) (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o))))
                                                  (plus (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o))) (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o)))))))))))) ** (lte108x27 o, fc108x27To96x21 o col)) where
  lte108x27 : (o:Nat) -> LTE (S (S (S (S (S (S (S (S (plus (plus (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o)))
                                              (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o))))
                                        (plus (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o)))
                                              (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o)))))))))))))
          (S (S (S (S (plus (plus (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))
                                  (S (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))))
                            (S (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))))))))
  lte108x27 Z = (lteSuccRight . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc) LTEZero
  lte108x27 (S o) = let lemma = lte108x27 o in
    rewrite (sym (plusSuccRightSucc o o)) in
    rewrite (sym (plusSuccRightSucc (plus o o)  (S (plus o o)))) in
    rewrite (sym (plusSuccRightSucc (plus o o)  (plus o o))) in
    rewrite (sym (plusSuccRightSucc (plus (plus o o) (plus o o))  (S (S (S (plus (plus o o) (plus o o))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus o o) (plus o o))  (S (S (plus (plus o o) (plus o o)))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus o o) (plus o o))  (S (plus (plus o o) (plus o o))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus o o) (plus o o))  (plus (plus o o) (plus o o)))) in
    rewrite (sym (plusSuccRightSucc (plus o o)  o)) in
    rewrite (sym (plusSuccRightSucc (plus (plus o o) o)  (S (S (plus (plus o o) o))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus o o) o)  (S (plus (plus o o) o)))) in
    rewrite (sym (plusSuccRightSucc (plus (plus o o) o)  (plus (plus o o) o))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus o o) o) (plus (plus o o) o))  (S (S (S (S (S (S (plus (plus (plus o o) o) (plus (plus o o) o)))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus o o) o) (plus (plus o o) o))  (S (S (S (S (S (plus (plus (plus o o) o) (plus (plus o o) o))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus o o) o) (plus (plus o o) o))  (S (S (S (S (plus (plus (plus o o) o) (plus (plus o o) o)))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus o o) o) (plus (plus o o) o))  (S (S (S (plus (plus (plus o o) o) (plus (plus o o) o))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus o o) o) (plus (plus o o) o))  (S (S (plus (plus (plus o o) o) (plus (plus o o) o)))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus o o) o) (plus (plus o o) o))  (S (plus (plus (plus o o) o) (plus (plus o o) o))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))  (S (S (S (S (S (S (S (S (S (S (S (S (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o)))))))))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))  (S (S (S (S (S (S (S (S (S (S (S (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))))))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))  (S (S (S (S (S (S (S (S (S (S (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o)))))))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))  (S (S (S (S (S (S (S (S (S (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))  (S (S (S (S (S (S (S (S (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o)))))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))  (S (S (S (S (S (S (S (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))  (S (S (S (S (S (S (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o)))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))  (S (S (S (S (S (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))  (S (S (S (S (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o)))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))  (S (S (S (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))  (S (S (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o)))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))  (S (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus (plus o o) o) (plus (plus o o) o))
                                                                                (S (plus (plus (plus o o) o) (plus (plus o o) o))))
                                                                                (S (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))))
                                    (S (S (S (S (S (S (S (S (S (S (S (S (plus (plus (plus (plus o o) o) (plus (plus o o) o))
                                                                                (S (plus (plus (plus o o) o)
                                                                                (plus (plus o o) o)))))))))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus (plus o o) o) (plus (plus o o) o))
                                                                                (S (plus (plus (plus o o) o) (plus (plus o o) o))))
                                                                                (S (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))))
                                    (S (S (S (S (S (S (S (S (S (S (S (plus (plus (plus (plus o o) o) (plus (plus o o) o))
                                                                                (S (plus (plus (plus o o) o)
                                                                                (plus (plus o o) o))))))))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus (plus o o) o) (plus (plus o o) o))
                                                                                (S (plus (plus (plus o o) o) (plus (plus o o) o))))
                                                                                (S (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))))
                                    (S (S (S (S (S (S (S (S (S (S (plus (plus (plus (plus o o) o) (plus (plus o o) o))
                                                                                (S (plus (plus (plus o o) o)
                                                                                (plus (plus o o) o)))))))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus (plus o o) o) (plus (plus o o) o))
                                                                                (S (plus (plus (plus o o) o) (plus (plus o o) o))))
                                                                                (S (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))))
                                    (S (S (S (S (S (S (S (S (S (plus (plus (plus (plus o o) o) (plus (plus o o) o))
                                                                                (S (plus (plus (plus o o) o)
                                                                                (plus (plus o o) o))))))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus (plus o o) o) (plus (plus o o) o))
                                                                                (S (plus (plus (plus o o) o) (plus (plus o o) o))))
                                                                                (S (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))))
                                    (S (S (S (S (S (S (S (S (plus (plus (plus (plus o o) o) (plus (plus o o) o))
                                                                                (S (plus (plus (plus o o) o)
                                                                                (plus (plus o o) o)))))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus (plus o o) o) (plus (plus o o) o))
                                                                                (S (plus (plus (plus o o) o) (plus (plus o o) o))))
                                                                                (S (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))))
                                    (S (S (S (S (S (S (S (plus (plus (plus (plus o o) o) (plus (plus o o) o))
                                                                                (S (plus (plus (plus o o) o)
                                                                                (plus (plus o o) o))))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus (plus o o) o) (plus (plus o o) o))
                                                                                (S (plus (plus (plus o o) o) (plus (plus o o) o))))
                                                                                (S (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))))
                                    (S (S (S (S (S (S (plus (plus (plus (plus o o) o) (plus (plus o o) o))
                                                                                (S (plus (plus (plus o o) o)
                                                                                (plus (plus o o) o)))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus (plus o o) o) (plus (plus o o) o))
                                                                                (S (plus (plus (plus o o) o) (plus (plus o o) o))))
                                                                                (S (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))))
                                    (S (S (S (S (S (plus (plus (plus (plus o o) o) (plus (plus o o) o))
                                                                                (S (plus (plus (plus o o) o)
                                                                                (plus (plus o o) o))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus (plus o o) o) (plus (plus o o) o))
                                                                                (S (plus (plus (plus o o) o) (plus (plus o o) o))))
                                                                                (S (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))))
                                    (S (S (S (S (plus (plus (plus (plus o o) o) (plus (plus o o) o))
                                                                                (S (plus (plus (plus o o) o)
                                                                                (plus (plus o o) o)))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus (plus o o) o) (plus (plus o o) o))
                                                                                (S (plus (plus (plus o o) o) (plus (plus o o) o))))
                                                                                (S (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))))
                                    (S (S (S (plus (plus (plus (plus o o) o) (plus (plus o o) o))
                                                                                (S (plus (plus (plus o o) o)
                                                                                (plus (plus o o) o))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus (plus o o) o) (plus (plus o o) o))
                                                                                (S (plus (plus (plus o o) o) (plus (plus o o) o))))
                                                                                (S (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))))
                                    (S (S (plus (plus (plus (plus o o) o) (plus (plus o o) o))
                                                                                (S (plus (plus (plus o o) o)
                                                                                (plus (plus o o) o)))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus (plus o o) o) (plus (plus o o) o))
                                                                                (S (plus (plus (plus o o) o) (plus (plus o o) o))))
                                                                                (S (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))))
                                    (S (plus (plus (plus (plus o o) o) (plus (plus o o) o))
                                                                                (S (plus (plus (plus o o) o)
                                                                                (plus (plus o o) o))))))) in

    rewrite (sym (plusSuccRightSucc (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o)))  (S (S (S (S (S (S (S (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o)))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o)))  (S (S (S (S (S (S (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o)))  (S (S (S (S (S (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o)))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o)))  (S (S (S (S (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o)))  (S (S (S (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o)))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o)))  (S (S (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o)))  (S (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o)))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o)))  (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o))))) in

    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus o o) (plus o o))
                                                                                (plus (plus o o) (plus o o)))
                                                                                (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o))))
                                    (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (plus (plus (plus (plus o o)
                                                                                (plus o o))
                                                                                (plus (plus o o)
                                                                                (plus o o)))
                                                                                (plus (plus (plus o o)
                                                                                (plus o o))
                                                                                (plus (plus o o)
                                                                                (plus o
                                                                                o))))))))))))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus o o) (plus o o))
                                                                                (plus (plus o o) (plus o o)))
                                                                                (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o))))
                                    (S (S (S (S (S (S (S (S (S (S (S (S (S (S (plus (plus (plus (plus o o)
                                                                                (plus o o))
                                                                                (plus (plus o o)
                                                                                (plus o o)))
                                                                                (plus (plus (plus o o)
                                                                                (plus o o))
                                                                                (plus (plus o o)
                                                                                (plus o
                                                                                o)))))))))))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus o o) (plus o o))
                                                                                (plus (plus o o) (plus o o)))
                                                                                (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o))))
                                    (S (S (S (S (S (S (S (S (S (S (S (S (S (plus (plus (plus (plus o o)
                                                                                (plus o o))
                                                                                (plus (plus o o)
                                                                                (plus o o)))
                                                                                (plus (plus (plus o o)
                                                                                (plus o o))
                                                                                (plus (plus o o)
                                                                                (plus o
                                                                                o))))))))))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus o o) (plus o o))
                                                                                (plus (plus o o) (plus o o)))
                                                                                (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o))))
                                    (S (S (S (S (S (S (S (S (S (S (S (S (plus (plus (plus (plus o o)
                                                                                (plus o o))
                                                                                (plus (plus o o)
                                                                                (plus o o)))
                                                                                (plus (plus (plus o o)
                                                                                (plus o o))
                                                                                (plus (plus o o)
                                                                                (plus o
                                                                                o)))))))))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus o o) (plus o o))
                                                                                (plus (plus o o) (plus o o)))
                                                                                (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o))))
                                    (S (S (S (S (S (S (S (S (S (S (S (plus (plus (plus (plus o o)
                                                                                (plus o o))
                                                                                (plus (plus o o)
                                                                                (plus o o)))
                                                                                (plus (plus (plus o o)
                                                                                (plus o o))
                                                                                (plus (plus o o)
                                                                                (plus o
                                                                                o))))))))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus o o) (plus o o))
                                                                                (plus (plus o o) (plus o o)))
                                                                                (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o))))
                                    (S (S (S (S (S (S (S (S (S (S (plus (plus (plus (plus o o)
                                                                                (plus o o))
                                                                                (plus (plus o o)
                                                                                (plus o o)))
                                                                                (plus (plus (plus o o)
                                                                                (plus o o))
                                                                                (plus (plus o o)
                                                                                (plus o
                                                                                o)))))))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus o o) (plus o o))
                                                                                (plus (plus o o) (plus o o)))
                                                                                (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o))))
                                    (S (S (S (S (S (S (S (S (S (plus (plus (plus (plus o o)
                                                                                (plus o o))
                                                                                (plus (plus o o)
                                                                                (plus o o)))
                                                                                (plus (plus (plus o o)
                                                                                (plus o o))
                                                                                (plus (plus o o)
                                                                                (plus o
                                                                                o))))))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus o o) (plus o o))
                                                                                (plus (plus o o) (plus o o)))
                                                                                (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o))))
                                    (S (S (S (S (S (S (S (S (plus (plus (plus (plus o o)
                                                                                (plus o o))
                                                                                (plus (plus o o)
                                                                                (plus o o)))
                                                                                (plus (plus (plus o o)
                                                                                (plus o o))
                                                                                (plus (plus o o)
                                                                                (plus o
                                                                                o)))))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus o o) (plus o o))
                                                                                (plus (plus o o) (plus o o)))
                                                                                (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o))))
                                    (S (S (S (S (S (S (S (plus (plus (plus (plus o o)
                                                                                (plus o o))
                                                                                (plus (plus o o)
                                                                                (plus o o)))
                                                                                (plus (plus (plus o o)
                                                                                (plus o o))
                                                                                (plus (plus o o)
                                                                                (plus o
                                                                                o))))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus o o) (plus o o))
                                                                                (plus (plus o o) (plus o o)))
                                                                                (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o))))
                                    (S (S (S (S (S (S (plus (plus (plus (plus o o)
                                                                                (plus o o))
                                                                                (plus (plus o o)
                                                                                (plus o o)))
                                                                                (plus (plus (plus o o)
                                                                                (plus o o))
                                                                                (plus (plus o o)
                                                                                (plus o
                                                                                o)))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus o o) (plus o o))
                                                                                (plus (plus o o) (plus o o)))
                                                                                (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o))))
                                    (S (S (S (S (S (plus (plus (plus (plus o o)
                                                                                (plus o o))
                                                                                (plus (plus o o)
                                                                                (plus o o)))
                                                                                (plus (plus (plus o o)
                                                                                (plus o o))
                                                                                (plus (plus o o)
                                                                                (plus o
                                                                                o))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus o o) (plus o o))
                                                                                (plus (plus o o) (plus o o)))
                                                                                (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o))))
                                    (S (S (S (S (plus (plus (plus (plus o o)
                                                                                (plus o o))
                                                                                (plus (plus o o)
                                                                                (plus o o)))
                                                                                (plus (plus (plus o o)
                                                                                (plus o o))
                                                                                (plus (plus o o)
                                                                                (plus o
                                                                                o)))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus o o) (plus o o))
                                                                                (plus (plus o o) (plus o o)))
                                                                                (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o))))
                                    (S (S (S (plus (plus (plus (plus o o)
                                                                                (plus o o))
                                                                                (plus (plus o o)
                                                                                (plus o o)))
                                                                                (plus (plus (plus o o)
                                                                                (plus o o))
                                                                                (plus (plus o o)
                                                                                (plus o
                                                                                o))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus o o) (plus o o))
                                                                                (plus (plus o o) (plus o o)))
                                                                                (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o))))
                                    (S (S (plus (plus (plus (plus o o)
                                                                                (plus o o))
                                                                                (plus (plus o o)
                                                                                (plus o o)))
                                                                                (plus (plus (plus o o)
                                                                                (plus o o))
                                                                                (plus (plus o o)
                                                                                (plus o
                                                                                o)))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus o o) (plus o o))
                                                                                (plus (plus o o) (plus o o)))
                                                                                (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o))))
                                    (S (plus (plus (plus (plus o o)
                                                                                (plus o o))
                                                                                (plus (plus o o)
                                                                                (plus o o)))
                                                                                (plus (plus (plus o o)
                                                                                (plus o o))
                                                                                (plus (plus o o)
                                                                                (plus o
                                                                                o))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus o o) (plus o o))
                                                                                (plus (plus o o) (plus o o)))
                                                                                (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o))))
                                    (plus (plus (plus (plus o o)
                                                                                (plus o o))
                                                                                (plus (plus o o)
                                                                                (plus o o)))
                                                                                (plus (plus (plus o o)
                                                                                (plus o o))
                                                                                (plus (plus o o)
                                                                                (plus o
                                                                                o)))))) in
      (lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc) lemma


module Main

readString : String -> IO String
readString d = pure d

test : String -> IO ()
test s = do
  s' <- readString s
  printLn (the Double (cast s'), the Integer (cast s'), the Int (cast s'))

bigInteger : IO Integer
bigInteger = pure 9223372036854775808

main : IO ()
main = do
  test "42.5"
  test "-42.5"
  test "42"
  test "-42"
  test "foo"
  printLn !bigInteger


f : Num a => a
f = g where
  g : Num a => a
  g = 0


module Idris.Codegen.ExtSTG.RepType

import Idris.Codegen.ExtSTG.SemiDecEq

public export
data PrimElemRep
  = Int8ElemRep
  | Int16ElemRep
  | Int32ElemRep
  | Int64ElemRep
  | Word8ElemRep
  | Word16ElemRep
  | Word32ElemRep
  | Word64ElemRep
  | FloatElemRep
  | DoubleElemRep

export
SemiDecEq PrimElemRep where
  semiDecEq Int8ElemRep   Int8ElemRep   = Just Refl
  semiDecEq Int16ElemRep  Int16ElemRep  = Just Refl
  semiDecEq Int32ElemRep  Int32ElemRep  = Just Refl
  semiDecEq Int64ElemRep  Int64ElemRep  = Just Refl
  semiDecEq Word8ElemRep  Word8ElemRep  = Just Refl
  semiDecEq Word16ElemRep Word16ElemRep = Just Refl
  semiDecEq Word32ElemRep Word32ElemRep = Just Refl
  semiDecEq Word64ElemRep Word64ElemRep = Just Refl
  semiDecEq FloatElemRep  FloatElemRep  = Just Refl
  semiDecEq DoubleElemRep DoubleElemRep = Just Refl
  semiDecEq _ _ = Nothing

Show PrimElemRep where
  show Int8ElemRep   = "Int8ElemRep"
  show Int16ElemRep  = "Int16ElemRep"
  show Int32ElemRep  = "Int32ElemRep"
  show Int64ElemRep  = "Int64ElemRep"
  show Word8ElemRep  = "Word8ElemRep"
  show Word16ElemRep = "Word16ElemRep"
  show Word32ElemRep = "Word32ElemRep"
  show Word64ElemRep = "Word64ElemRep"
  show FloatElemRep  = "FloatElemRep"
  show DoubleElemRep = "DoubleElemRep"

public export
data PrimRep
  = VoidRep
  | LiftedRep   -- Boxed, in thunk or WHNF
  | UnliftedRep -- Boxed, in WHNF
  | Int8Rep     -- Unboxed, Signed, 8 bits value
  | Int16Rep    -- Unboxed, Signed, 16 bits value
  | Int32Rep    -- Unboxed, Signed, 32 bits value
  | Int64Rep    -- Unboxed, Signed, 64 bits value (with 32 bits words only)
  | IntRep      -- Unboxed, Signed, word-sized value
  | Word8Rep    -- Unboxed, Unsigned, 8 bits value
  | Word16Rep   -- Unboxed, Unsigned, 16 bits value
  | Word32Rep   -- Unboxed, Unsigned, 32 bits value
  | Word64Rep   -- Unboxed, Unisgned, 64 bits value (with 32 bits words only)
  | WordRep     -- Unboxed, Unisgned, word-sized value
  | AddrRep     -- A pointer, but *not* a Haskell value. Use (Un)liftedRep
  | FloatRep
  | DoubleRep
  | VecRep Nat PrimElemRep -- A vector

export
SemiDecEq PrimRep where
  semiDecEq VoidRep     VoidRep     = Just Refl
  semiDecEq LiftedRep   LiftedRep   = Just Refl
  semiDecEq UnliftedRep UnliftedRep = Just Refl
  semiDecEq Int8Rep     Int8Rep     = Just Refl
  semiDecEq Int16Rep    Int16Rep    = Just Refl
  semiDecEq Int32Rep    Int32Rep    = Just Refl
  semiDecEq Int64Rep    Int64Rep    = Just Refl
  semiDecEq IntRep      IntRep      = Just Refl
  semiDecEq Word8Rep    Word8Rep    = Just Refl
  semiDecEq Word16Rep   Word16Rep   = Just Refl
  semiDecEq Word32Rep   Word32Rep   = Just Refl
  semiDecEq Word64Rep   Word64Rep   = Just Refl
  semiDecEq WordRep     WordRep     = Just Refl
  semiDecEq AddrRep     AddrRep     = Just Refl
  semiDecEq FloatRep    FloatRep    = Just Refl
  semiDecEq DoubleRep   DoubleRep   = Just Refl
  semiDecEq (VecRep n1 p1) (VecRep n2 p2) = do
    Refl <- semiDecEq p1 p2
    Refl <- semiDecEq n1 n2
    Just Refl
  semiDecEq _ _ = Nothing

export
Show PrimRep where
  showPrec d VoidRep      = "VoidRep"
  showPrec d LiftedRep    = "LiftedRep"
  showPrec d UnliftedRep  = "UnliftedRep"
  showPrec d Int8Rep      = "Int8Rep"
  showPrec d Int16Rep     = "Int16Rep"
  showPrec d Int32Rep     = "Int32Rep"
  showPrec d Int64Rep     = "Int64Rep"
  showPrec d IntRep       = "IntRep"
  showPrec d Word8Rep     = "Word8Rep"
  showPrec d Word16Rep    = "Word16Rep"
  showPrec d Word32Rep    = "Word32Rep"
  showPrec d Word64Rep    = "Word64Rep"
  showPrec d WordRep      = "WordRep"
  showPrec d AddrRep      = "AddrRep"
  showPrec d FloatRep     = "FloatRep"
  showPrec d DoubleRep    = "DoubleRep"
  showPrec d (VecRep n p) = showCon d "VecRep" $ showArg n ++ " " ++ showArg p

||| SingeValue LiftedRep = Simple Algebraic value
public export
data RepType
  = SingleValue    PrimRep
  | UnboxedTuple   (List PrimRep)
  | PolymorphicRep

export
Show RepType where
  showPrec d (SingleValue p)   = showCon d "SingleValue" $ showArg p
  showPrec d (UnboxedTuple ps) = showCon d "UnboxedTuple" $ showArg ps
  showPrec d PolymorphicRep    = "PolymorphicRep"

export
SemiDecEq RepType where
  semiDecEq (SingleValue p1) (SingleValue p2) = do
    Refl <- semiDecEq p1 p2
    Just Refl
  semiDecEq (UnboxedTuple p1) (UnboxedTuple p2) = do
    Refl <- semiDecEq p1 p2
    Just Refl
  semiDecEq PolymorphicRep PolymorphicRep = Just Refl
  semiDecEq _ _ = Nothing


import Data.Strings

VendState : Type
VendState = (Nat, Nat)

data Input = COIN
           | VEND
           | CHANGE
           | REFILL Nat

strToInput : String -> Maybe Input
strToInput "insert" = Just COIN
strToInput "vend" = Just VEND
strToInput "change" = Just CHANGE
strToInput x = if all isDigit (unpack x)
                  then Just (REFILL (stringToNatOrZ x))
                  else Nothing

export
data MachineCmd : Type ->
                  VendState -> VendState ->
                  Type where
  InsertCoin : MachineCmd () (pounds, chocs)     (S pounds, chocs)
  Vend :       MachineCmd () (S pounds, S chocs) (pounds, chocs)
  GetCoins :   MachineCmd () (pounds, chocs)     (Z, chocs)

  Refill : (bars : Nat) ->
           MachineCmd () (Z, chocs) (Z, bars + chocs)

  Display : String -> MachineCmd ()            state state
  GetInput :          MachineCmd (Maybe Input) state state

  Pure : ty -> MachineCmd ty state state
  (>>=) : {state2 : _} ->
          MachineCmd a state1 state2 ->
          (a -> MachineCmd b state2 state3) ->
          MachineCmd b state1 state3

export
data MachineIO : VendState -> Type where
  Do : {state1 : _} ->
       MachineCmd a state1 state2 ->
       (a -> Inf (MachineIO state2)) -> MachineIO state1

runMachine : {inState : _} -> MachineCmd ty inState outState -> IO ty
runMachine InsertCoin = putStrLn "Coin inserted"
runMachine Vend = putStrLn "Please take your chocolate"
runMachine {inState = (pounds, _)} GetCoins
     = putStrLn (show pounds ++ " coins returned")
runMachine (Display str) = putStrLn str
runMachine (Refill bars)
     = putStrLn ("Chocolate remaining: " ++ show bars)
runMachine {inState = (pounds, chocs)} GetInput
     = do putStrLn ("Coins: " ++ show pounds ++ "; " ++
                    "Stock: " ++ show chocs)
          putStr "> "
          x <- getLine
          pure (strToInput x)
runMachine (Pure x) = pure x
runMachine (cmd >>= prog) = do x <- runMachine cmd
                               runMachine (prog x)
namespace MachineDo
  export
  (>>=) : {state1 : _} ->
          MachineCmd a state1 state2 ->
          (a -> Inf (MachineIO state2)) -> MachineIO state1
  (>>=) = Do

data Fuel = Dry | More (Lazy Fuel)

partial
forever : Fuel
forever = More forever

run : Fuel -> MachineIO state -> IO ()
run (More fuel) (Do c f)
     = do res <- runMachine c
          run fuel (f res)
run Dry p = pure ()

mutual
  vend : {pounds : _} -> {chocs : _} -> MachineIO (pounds, chocs)
  vend {pounds = (S p)} {chocs = (S c)} = do Vend
                                             Display "Enjoy!"
                                             machineLoop
  vend {pounds = Z} = do Display "Insert a coin"
                         machineLoop
  vend {chocs = Z} = do Display "Out of stock"
                        machineLoop

  refill: {pounds : _} -> {chocs : _} -> (num : Nat) -> MachineIO (pounds, chocs)
  refill {pounds = Z} num = do Refill num
                               machineLoop
  refill _ = do Display "Can't refill: Coins in machine"
                machineLoop

  machineLoop : {pounds : _} -> {chocs : _} -> MachineIO (pounds, chocs)
  machineLoop = do Just x <- GetInput
                             | Nothing => do Display "Invalid input"
                                             machineLoop
                   case x of
                        COIN => do InsertCoin
                                   machineLoop
                        VEND => vend
                        CHANGE => do GetCoins
                                     Display "Change returned"
                                     machineLoop
                        REFILL num => refill num

main : IO ()
main = run forever (machineLoop {pounds = 0} {chocs = 1})