import Data.Vect

{-
data Range : (begin : Nat) -> (end : Nat) -> Type where
  EmptyRange : Range 0 0
  MkRange : (begin : Nat) -> (end: Nat) -> Range begin end

interface Encoding a where
  alphabet : Range n m
  digit : Range n m

Encoding ASCII where
  alphabet = MkRange 64 116
  digit = MkRange 48 60

Cast ASCII Char where
  cast (MkASCII n) = chr (cast n)
-}

data ASCII : Type where
  MkASCII : ASCII

data Unicode : Type where
  MkUnicode : Unicode

interface Encoding a where
  alphabet : a -> (Nat, Nat)
  upper : a -> (Nat, Nat)
  digits : a -> (Nat, Nat)

Encoding ASCII where
  alphabet MkASCII = (64, 116)
  upper MkASCII = (64, 66)
  digits MkASCII = (0, 9)

Encoding Unicode where
  alphabet MkUnicode = (0, 52)
  upper MkUnicode = (64, 66)
  digits MkUnicode = (100, 109)

inRangeProof : (Nat, Nat) -> Nat -> Type
inRangeProof (min, max) n = case (min <= n) && (n <= max) of
                                 True => Elem True [True]
                                 False => Elem False [True]

data Character : e -> Nat -> Type where
  Digit  : Encoding e =>
           (e' : e) ->
           (n : Nat) ->
           { auto inRange : inRangeProof (digits e') n } ->
           Character e' n

  Upper : Encoding e =>
          (e' : e) ->
          (n : Nat) ->
          { auto inRange : inRangeProof (upper e') n } ->
          Character e' n

  Letter  : Encoding e =>
            (e' : e) ->
            (n : Nat) ->
            { auto inRange : inRangeProof (alphabet e') n } ->
            Character e' n

isDigit : Character e n -> Nat
isDigit (Digit e n) = 0
isDigit (Upper e n) = 1
isDigit (Letter e n) = 2


module Data.OrderedVect

import Decidable.Order

%default total

mutual
  public export
  data OrderedVect : Nat -> (constraint : Ordered ty to) -> Type where
    Nil : .{auto constraint : Ordered ty to}
        -> OrderedVect Z constraint
    (::) : .{constraint : Ordered ty to}
        -> (x : ty)
        -> (v : OrderedVect n constraint)
        -> .{auto prf : Fits x v}
        -> OrderedVect (S n) constraint

  public export
  Fits : {constraint : Ordered ty to} -> ty -> OrderedVect n constraint -> Type
  Fits _ Nil = ()
  Fits n (m :: _) = to n m

%name OrderedVect xs,ys,zs

export
head : .{constraint : Ordered ty to} -> OrderedVect (S _) constraint -> ty
head (x :: _) = x

fitsTrans : (Fits {constraint} x ys) -> Fits {constraint} (head ys) zs -> Fits {constraint} x zs
fitsTrans {zs = []} _ _ = ()
fitsTrans {x} {ys = y' :: _} {zs = z' :: _} rel1 rel2 = transitive x y' z' rel1 rel2

mutual
  merge' : .{constraint : Ordered ty to}
        -> {n : Nat}
        -> (v1 : OrderedVect (S n) constraint)
        -> {m : Nat}
        -> (v2 : OrderedVect (S m) constraint)
        -> (ret : OrderedVect ((S n) + (S m)) constraint ** Either (Fits (head v1) ret) (Fits (head v2) ret))
  merge' [] _ impossible
  merge' _ [] impossible
  merge' {to} [x] [y] = case order {to} x y of
                        Left prf => ([x, y] ** Left (reflexive x))
                        Right prf => ([y, x] ** Right (reflexive y))
  merge' {m} [x] (y :: ys) = rewrite sym $ plusZeroRightNeutral m in
                             rewrite plusSuccRightSucc m Z in
                             case assert_total $ merge' (y :: ys) [x] of
                             (ref ** Left prf) => (ref ** Right prf)
                             (ref ** Right prf) => (ref ** Left prf)
  merge' {n = S cntX} (x :: xs) [y]
    = case order {to} x y of
      Left prf => case mergeHelper xs [y] x of
                  (zs ** fitsPrf) => (zs ** Left fitsPrf)
      Right prf => rewrite sym $ plusSuccRightSucc cntX Z in
                   rewrite plusZeroRightNeutral cntX in
                   ((y :: x :: xs) ** Right (reflexive y))
  merge' ((::) {n = S cntX} x (x' :: xs'))
        ((::) {n = S cntY} y (y' :: ys'))
    = case order {to} x y of
      Left prf => case mergeHelper (x' :: xs') (y :: y' :: ys') x of
                  (zs ** fitsPrf) => (zs ** Left fitsPrf)
      Right prf => case mergeHelper (y' :: ys') (x :: x' :: xs') y of
                   (zs ** fitsPrf) => rewrite plusCommutative cntX (S $ S $ cntY) in
                                      rewrite plusSuccRightSucc (S $ S cntY) cntX in
                                      rewrite plusSuccRightSucc (S cntY) (S cntX) in
                                      (zs ** Right fitsPrf)
  mergeHelper : .{constraint : Ordered ty to}
             -> {n : Nat}
             -> (xs : OrderedVect (S n) constraint)
             -> {m : Nat}
             -> (ys : OrderedVect (S m) constraint)
             -> (x : ty)
             -> .{auto prfXs : Fits x xs}
             -> .{auto prfYs : Fits x ys}
             -> (ret : OrderedVect (S $ (S n) + (S m)) constraint ** Fits x ret)
  mergeHelper xs ys x {prfXs} {prfYs}
    = case assert_total $ merge' xs ys of
      (zs ** Left fitsPrf) => let _ = fitsTrans prfXs fitsPrf in
                              (x :: zs ** reflexive x)
      (zs ** Right fitsPrf) => let _ = fitsTrans prfYs fitsPrf in
                               (x :: zs ** reflexive x)

export
merge : {constraint : Ordered ty to}
     -> (n : Nat)
     -> OrderedVect n constraint
     -> (m : Nat)
     -> OrderedVect m constraint
     -> OrderedVect (n + m) constraint
merge Z     [] Z     [] = Nil
merge n     v1 Z     [] = rewrite plusZeroRightNeutral n in v1
merge Z     [] _     v2 = v2
merge (S _) v1 (S _) v2 = fst $ merge' v1 v2

export
tail : OrderedVect (S n) constraint -> OrderedVect n constraint
tail (_ :: v) = v

export
orderedVectToList : .{constraint : Ordered ty _} -> OrderedVect n constraint -> List ty
orderedVectToList [] = []
orderedVectToList {n = S _} (x :: xs) = x :: (orderedVectToList xs)


module Expr

data Expr : Type where
  Value : (a:Int) -> Expr
  Plus : Expr -> Expr -> Expr
  Minus : Expr -> Expr -> Expr
  Mult : Expr -> Expr -> Expr

evaluate : Expr -> Int
evaluate (Value x) = x
evaluate (Plus x y) = (evaluate x) + (evaluate y)
evaluate (Minus x y) = (evaluate x) - (evaluate y)
evaluate (Mult x y) = (evaluate x) * (evaluate y)


module FunExt

public export
funext : {a : Type} -> {b : a -> Type} ->
         {f, g : (1 x : a) -> b x} -> (0 _ : (1 x : a) -> f x = g x) -> f = g
funext _  = believe_me ()

public export
funextW : {a : Type} -> {b : a -> Type} ->
          {f, g : (x : a) -> b x} -> (0 _ : (x : a) -> f x = g x) -> f = g
funextW _  = believe_me ()

public export
0 piext : {a : Type} -> {b : a -> Type} -> {b' : a -> Type} ->
         (0 _ : (1 x : a) -> b x = b' x) ->
         ((1 x : a) -> b x) = ((1 x : a) -> b' x)
piext p = cong (\ z => (1 x : a) -> z x) (funext p)


module Part2.Sec6_1_1_tyfunc
import Data.Vect

{-
Fewer concept == smaller conceptual complexity
type aliasing is simply a type level function!!!
-}

||| Type level function with no params
Position : Type
Position = (Double, Double)

testData : List (Double, Double)
testData = [(1,2),(1,3.1)]

testData' : List Position
testData' = [(1,2),(1,3.1)]

||| Naive test function
sumFirst : List Position -> Double
sumFirst list = sum (map fst list)

||| Type level function with one param
Polygon : Nat -> Type
Polygon n = Vect n Position

tri : Polygon 3
tri = [(0.0, 0.0), (3.0, 0.0), (0.0, 4.0)]

||| One param function acting as type synomym
MyList : Type -> Type
MyList = List

testMyList : MyList Integer -> MyList Integer
testMyList = map (+1)


module Graphics.Util.Transforms

import Data.So
import Data.Matrix
import Data.Matrix.Algebraic
import Data.Vect
import Control.Algebra
import Debug.Trace

%access public export

-- ----------------------------------------------------------------- [ Types ]

data Angle = Radians Double | Degree Double

Pos : Type
Pos = Vect 3 Double

TransformationMatrix : Type
TransformationMatrix = Matrix 4 4 Double

vmult : Matrix n m Double -> Vect m Double -> Vect n Double
vmult m v = map (<:> v) m

-- ----------------------------------------------------------------- [ Utilities ]
data Interval : Type where
   MkInterval : (lower : Double) -> (upper : Double) ->
                So (lower < upper) -> Interval

pattern syntax "[" [x] "..." [y] "]" = MkInterval x y Oh
term    syntax "[" [x] "..." [y] "]" = MkInterval x y ?bounds_lemma

UnitInterval : Interval
UnitInterval = MkInterval 0.0 1.0 Oh

clamp : Double -> Interval -> Double
clamp val (MkInterval lower upper _) =
  if val < lower
  then lower
  else if val > upper
       then upper
       else val

-- ----------------------------------------------------------------- [ Angles ]

export
getRadians : Angle -> Double
getRadians (Radians a) = a
getRadians (Degree a)  = a * pi / 180

private
cosA : Angle -> Double
cosA a = cos $ getRadians a

private
sinA : Angle -> Double
sinA a = sin $ getRadians a

-- ----------------------------------------------------------------- [ Vectors + Matrices ]

||| 3D Vector cross product
cross: Pos -> Pos -> Pos
cross (x1 :: x2 :: x3 :: []) (y1 :: y2 :: y3 :: []) = [x2*y3-x3*y2, x3*y1-x1*y3, x1*y2-x2*y1]

dot: Pos -> Pos -> Double
dot x y = x <:> y

||| scalar multiplication
scalar : Double -> Vect n Double -> Vect n Double
scalar s v = map (\e => s*e) v

norm : Vect n Double -> Double
norm v = sqrt $ v <:> v

||| normalizes a vector to a unit vector
normalize : Vect n Double -> Vect n Double
normalize v = map (\e => e / l ) v
              where l = norm v

||| convert to a row major List
toGl : TransformationMatrix -> Vect 16 Double
toGl m = concat $ transpose m

-- ----------------------------------------------------------------- [ Transformation Matrices ]

identity : TransformationMatrix
identity = [
           [1, 0, 0, 0],
           [0, 1, 0, 0],
           [0, 0, 1, 0],
           [0, 0, 0, 1]
           ]

translate : Pos -> TransformationMatrix
translate (x :: y :: z :: []) = [
           [1, 0, 0, x],
           [0, 1, 0, y],
           [0, 0, 1, z],
           [0, 0, 0, 1]
           ]

scale : Pos -> TransformationMatrix
scale (sx :: sy :: sz :: []) = [
           [sx, 0,  0, 0],
           [0, sy,  0, 0],
           [0,  0, sz, 0],
           [0,  0,  0, 1]
           ]

scaleAll : Double -> TransformationMatrix
scaleAll s = scale [s, s, s]

rotateX : Angle -> TransformationMatrix
rotateX angle = [
           [1,       0,         0,  0],
           [0,  (cos a),  -(sin a), 0],
           [0,  (sin a),   (cos a), 0],
           [0,       0,         0,  1]
           ]
           where a = getRadians angle

rotateY : Angle -> TransformationMatrix
rotateY angle = [
           [  (cos a),       0, (sin a),  0],
           [       0 ,       1,      0 ,  0],
           [ -(sin a),       0, (cos a),  0],
           [       0 ,       0,      0 ,  1]
           ]
           where a = getRadians angle

rotateZ : Angle -> TransformationMatrix
rotateZ angle = [
           [  (cos a), -(sin a), 0,  0],
           [  (sin a),  (cos a), 0,  0],
           [       0 ,       0 , 1,  0],
           [       0 ,       0,  0,  1]
           ]
           where a = getRadians angle

rotate : Vect 3 Angle -> TransformationMatrix
rotate (ax :: ay :: az :: []) = (rotateX ax) <> (rotateY ay) <> (rotateZ az)

-- ----------------------------------------------------------------- [ Projection Matrices ]

orthographicProjection : (Double, Double) -> (Double, Double) -> (Double, Double) -> TransformationMatrix
orthographicProjection (right, left) (top, bottom) (near, far) = [
           [ 2/(right-left),              0,             0,  -(right + left)/ (right-left)],
           [       0,        2/(top-bottom),             0,  -(top+bottom)  / (top-bottom)],
           [       0,                     0, -2/(far-near),  -(far+near)    / (far-near)  ],
           [       0,                     0,             0,                1              ]
           ]

||| Matrix for Perspective Projection
||| @ fov    field of view / viewing angle
||| @ aspect aspect ration for the projection
||| @ clipping near and far clipping planes
perspectiveProjection : (fov: Angle) -> (aspect: Double) -> (clipping: (Double, Double)) -> TransformationMatrix
perspectiveProjection fov aspect (near, far) = [
           [ 2 * near/(right-left),                    0,  (right + left)/ (right-left),              0                ],
           [       0,                2*near/(top-bottom),  (top+bottom)  / (top-bottom),              0                ],
           [       0,                                  0, -(far+near)    / (far - near), -2 * far * near / (far - near)],
           [       0,                                  0,               -1             ,              0                ]
           ]
           where top    = near * tan((getRadians fov)/ 2)
                 bottom = -top
                 right  = top * aspect
                 left   = -right

||| transformation matrix to transform from world coordinates to view coordinates
||| @ eye where the camera aims - a vector
||| @ center location of the center of the camera
||| @ up up direction for the viewer
viewMatrix : (eye: Pos) -> (center: Pos) -> (up: Pos) -> TransformationMatrix
viewMatrix eye center up = (transpose m) ++ [v]
                           where
                               f : Pos
                               f = normalize (eye <-> center)
                               s : Pos
                               s = normalize (cross f up)
                               u : Pos
                               u = cross s f
                               m : Matrix 4 3 Double
                               m = [s, u, (scalar (-1) f), [0,0,0]]
                               v : Vect 4 Double
                               v = [0,0,0,1]

||| a view matrix where the camera is located at the origin and points down the z-axis
||| while the y-axis is the "up" direction
defaultViewMatrix : TransformationMatrix
defaultViewMatrix = viewMatrix [0,0,-1] [0,0,0] [0,1,0]

||| a view matrix for a camer located at the origin
||| @ eye direction of the camera (where the camera is pointing)
standardViewMatrix : (eye: Pos) -> TransformationMatrix
standardViewMatrix eye = viewMatrix eye [0,0,0] [0,1,0]

-- ----------------------------------------------------------------- [ Quaternions ]

-- Quaternions
-- TODO: introduce a separate type for unit quaternions
namespace Quaternions

  record Quaternion where
    constructor Q
    scalar : Double
    vector : Vect 3 Double

  realPart : Quaternion -> Double
  realPart = scalar

  imagPart : Quaternion -> Vect 3 Double
  imagPart = vector

  qnorm : Quaternion -> Double
  qnorm (Q s v) = let q = s :: v
                  in norm q

  implementation Show Quaternion where
    show (Q s (v1 :: v2 :: v3 :: [])) = (show s)++" + " ++ (show v1) ++"i + "++ (show v2) ++ "k + "++ (show v3)++"j"

  implementation Eq Quaternion where
    (==) q p = realPart q == realPart p && imagPart q == imagPart p

  ||| returns the quaternion as a 4 dimensional Vector with the scalar part last
  ||| this corresponds to the representation as a (x,y,z,w) vector
  toVect : Quaternion -> Vect 4 Double
  toVect (Q s v) = v ++ [s]

  fromVect : Vect 4 Double -> Quaternion
  fromVect (x :: y :: z :: w :: Nil) = Q w [x, y, z]

  export
  fromAxis : (rotation: Angle) -> (axis: Vect 3 Double) -> Quaternion
  fromAxis rot (bx :: by :: bz :: Nil) =
    let a = (getRadians rot) / 2
    in Q (cos a) [(sin a)*bx, (sin a)*by, (sin a)*bz]

  toMatrix : Quaternion -> TransformationMatrix
  toMatrix q@(Q w (x :: y :: z :: Nil)) =
    let s = 2 / (qnorm q)
    in [
       [(1-s*(y*y+z*z)),     s*(x*y-w*z),       s*(x*z+w*y),   0],
       [    s*(x*y+w*z),  (1-s*(x*x+z*z)),      s*(y*z-w*x),   0],
       [    s*(x*z-w*y),     s*(y*z+w*x),    (1-s*(x*x+y*y)),  0],
       [              0,               0,                 0,   1]
       ]

  conjugate : Quaternion -> Quaternion
  conjugate (Q s v) = Q s (scalar (-1) v)

  qsum : Quaternion -> Quaternion -> Quaternion
  qsum (Q s1 v1) (Q s2 v2) = Q (s1+s2) (v1 <+> v2)

  qmultiply : Quaternion -> Quaternion -> Quaternion
  qmultiply (Q s1 v1) (Q s2 v2) = Q (s1*s2 - (dot v1 v2)) ( (scalar s1 v2) <+> (scalar s2 v1) <+> (cross v1 v2))

  qinverse : Quaternion -> Quaternion
  qinverse q@(Q s v) = let q' = s :: v
                           q'' = (1 / (q' <:> q'))
                       in Q (s / q'') (scalar q'' v)

  ||| Exponential e^q
  qexp : Quaternion -> Quaternion
  qexp (Q s v) = let n = norm v
                     e = exp s
                 in Q (e * cos n) ( scalar ((sin n) / n) v)

  qlog : Quaternion -> Quaternion
  qlog q@(Q s v) = let q' = qnorm q
                   in Q (log q') (scalar ((acos (s / q')) / (norm v)) v)

  qnormalize : Quaternion -> Quaternion
  qnormalize q = fromVect $ normalize (toVect q)

  ||| x ^ y
  rpow : Double -> Double -> Double
  rpow y x = let e = x * (log (abs y))
             in if y < 0
                then 1 / (exp e)
                else if y > 0
                     then exp e
                     else 1

  ||| q^t where t is a Real
  qpow : Quaternion -> Double -> Quaternion
  qpow q@(Q s v) a = let e     = (rpow (qnorm q) a)
                         theta = acos (s / (qnorm q))
                     in Q (e * cos (s * theta)) (scalar (sin (s*theta)) v)

  ||| scalar multiplication
  qscalar : Double -> Quaternion -> Quaternion
  qscalar s (Q w v) = Q (s*w) (scalar s v)

  data GimbalPole = NorthPole | SouthPole | NoPole

  ||| Get the pole of the gimbal lock, if any.
  ||| If we have either a north pole or a south pole there is a gimbal lock
  gimbalPole : Quaternion -> GimbalPole
  gimbalPole (Q s v) = let v' = s :: v
                           n' = v' <:> v'
                       in if n' > 0.499
                          then NorthPole
                          else if n' < -0.499
                               then SouthPole
                               else NoPole

  gimbalMultiplier : GimbalPole -> Double
  gimbalMultiplier NoPole    = 0
  gimbalMultiplier NorthPole = 1
  gimbalMultiplier SouthPole = -1

  -- conversion between euler angles and quaternions
  -- see https://en.wikipedia.org/wiki/Conversion_between_quaternions_and_Euler_angles

  ||| the roll = rotation around x-axis
  export
  roll : Quaternion -> Angle
  roll q = let q' = qnormalize q
               (Q w (x :: y :: z :: Nil)) = q'
           in case (gimbalPole q) of
                   NoPole    => Radians $ atan2 (2*(w*z + y*x)) (1 - 2*(x*x+z*z))
                   p@(_)     => Radians $ (2 * (atan2 y w)) * (gimbalMultiplier p)

  ||| rotation around y-axis
  export
  pitch : Quaternion -> Angle
  pitch q = let q' = qnormalize q
                (Q w (x :: y :: z :: Nil)) = q'
            in case (gimbalPole q) of
                    NoPole => Radians $ asin (2*(w*x - z*y)) -- might need clamping for asin
                    _      => Radians $ (pi / 2)

  ||| rotation around z-axis
  export
  yaw : Quaternion -> Angle
  yaw q = let q' = qnormalize q
              (Q w (x :: y :: z :: Nil)) = q'
          in case (gimbalPole q) of
                    NoPole => Radians $ atan2 (2*(y*w + x*z)) (1 - 2*(y*y + x*x))
                    _      => Radians $ 0

  ||| creates a quaternion from a vector of euler angles
  export
  fromEulerAngles : Vect 3 Angle -> Quaternion
  fromEulerAngles (yaw :: pitch :: roll :: Nil) =
    let yawR = (getRadians yaw) / 2; pitchR = (getRadians pitch) / 2; rollR = (getRadians roll) / 2
        w    = (cos yawR) * (cos pitchR) * (cos rollR) + (sin yawR) * (sin pitchR) * (sin rollR)
        x    = (cos yawR) * (sin pitchR) * (cos rollR) + (sin yawR) * (cos pitchR) * (sin rollR)
        y    = (sin yawR) * (cos pitchR) * (cos rollR) - (cos yawR) * (sin pitchR) * (sin rollR)
        z    = (cos yawR) * (cos pitchR) * (sin rollR) - (sin yawR) * (sin pitchR) * (cos rollR)
    in (Q w [x,y,z])

  export
  toEulerAngles : Quaternion -> Vect 3 Angle
  toEulerAngles q = [roll q, pitch q, yaw q]

  export
  fromCross : Vect 3 Double -> Vect 3 Double-> Quaternion
  fromCross v1 v2 = let theta = acos (dot (normalize v1) (normalize v2))
                        vec   = cross (normalize v1) (normalize v2)
                    in fromAxis (Radians theta) vec

  {--
  slerpBetween : Vect (S n) Quaternion -> Quaternion
  slerpBetween qs = ?slerpBetween

  slerpBetweenWeighted : Vect (S n) (Quaternion, Double) -> Quaternion
  slerpBetweenWeighted qs = ?slerpBetweenWeighted
  --}

  -- ----------------------------------------------------------------- [ Algenbraic Classes for Quaternions ]

  implementation Semigroup Quaternion where
    (<+>) = qsum

  implementation Monoid Quaternion where
    neutral = Q 0 [0, 0, 0]

  implementation Group Quaternion where
    inverse (Q s v) = Q (-1*s) (scalar (-1) v)

  implementation AbelianGroup Quaternion where {}

  implementation Ring Quaternion where
    (<.>) = qmultiply

  implementation RingWithUnity Quaternion where
    unity = Q 1 [0,0,0]

  implementation Num Quaternion where
    (+) = qsum
    (*) = qmultiply
    fromInteger x = Q (fromInteger x) [0,0,0]

  implementation Field Quaternion where
    inverseM q _ = qinverse q

  -- ----------------------------------------------------------------- [ Quaternion Rotation ]

  qrotate : Vect 3 Double -> Quaternion -> Vect 3 Double
  qrotate v q = let p  = Q 0 v        -- make the vector a quaternion
                    q' = qnormalize q -- normalize the rotation quaternion (until we have unit quaternions as a type)
                    in imagPart $ q' <.> p <.> (conjugate q')

  ||| linear interpolation of quaternions
  ||| TODO handle corner cases (sintheta < 0.00001)
  slerp : Quaternion -> Quaternion -> Double -> Quaternion
  slerp q0 q1 t = let n1 = qnormalize q0
                      n2 = qnormalize q1
                      theta = acos ((toVect n1) <:> (toVect n2))
                      sintheta = sin theta
                      weight1 = (sin (theta * (1-t))) / sintheta
                      weight2 = (sin (theta*t)) / sintheta
                  in ((qscalar weight1 n1) + (qscalar weight2 n2))

{--
// if theta = 180 degrees then result is not fully defined
	// we could rotate around any axis normal to qa or qb
	if (fabs(sinHalfTheta) < 0.001){ // fabs is floating point absolute
		qm.w = (qa.w * 0.5 + qb.w * 0.5);
		qm.x = (qa.x * 0.5 + qb.x * 0.5);
		qm.y = (qa.y * 0.5 + qb.y * 0.5);
		qm.z = (qa.z * 0.5 + qb.z * 0.5);
		return qm;
	}
--}

{--
#define SLERP_TO_LERP_SWITCH_THRESHOLD 0.01f

Quaternion Quaternion_slerp(Quaternion left, Quaternion right, float value) {
	float leftWeight, rightWeight, difference;
	Quaternion result;

	difference = left.x * right.x + left.y * right.y + left.z * right.z + left.w * right.w;
	if (1.0f - fabs(difference) > SLERP_TO_LERP_SWITCH_THRESHOLD) {
		float theta, oneOverSinTheta;

		theta = acos(fabs(difference));
		oneOverSinTheta = 1.0f / sin(theta);
		leftWeight = sin(theta * (1.0f - value)) * oneOverSinTheta;
		rightWeight = sin(theta * value) * oneOverSinTheta;
		if (difference < 0.0f) {
			leftWeight = -leftWeight;
		}
	} else {
		leftWeight = 1.0f - value;
		rightWeight = value;
	}
	result.x = left.x * leftWeight + right.x * rightWeight;
	result.y = left.y * leftWeight + right.y * rightWeight;
	result.z = left.z * leftWeight + right.z * rightWeight;
	result.w = left.w * leftWeight + right.w * rightWeight;
	Quaternion_normalize(&result);

	return result;
}
--}


-- ----------------------------------------------------------- [ DataTypes.idr ]
-- Module      : Exercises.DataTypes
-- Description : Solutions to the Chapter 4 exercises in Edwin Brady's
--               book, "Type-Driven Development with Idris."
-- --------------------------------------------------------------------- [ EOH ]
module Exercises.DataTypes

import public Chapter.DataTypes
import public Data.Vect

%access export

on : (b -> b -> c) -> (a -> b) -> a -> a -> c
on g f = \x,y => f x `g` f y

onIdentity : -- ((*) : b -> b -> c) ->
             ((*) `on` Basics.id) x y = (*) x y
onIdentity = Refl

onComposition : -- ((*) : c -> c -> d) -> (f : b -> c) -> (g : a -> b) ->
                (((*) `on` f) `on` g) x y = ((*) `on` (f . g)) x y
onComposition = Refl

flipOn : (a -> b) -> (b -> b -> c) -> a -> a -> c
flipOn = flip on

onFlip : -- (f : a -> b) -> (g : b -> c) ->
         (flipOn f . flipOn g) h x y = (flipOn (g . f)) h x y
onFlip = Refl

-- --------------------------------------------------------- [ 4.1.5 Exercises ]

||| Insert every element of a list into a binary search tree.
|||
||| ```idris example
||| listToTree [1,4,3,5,2]
||| ```
listToTree : Ord a => List a -> Tree a
listToTree = foldr insert Empty

||| Flatten a tree into a list using *inorder* traversal.
|||
||| ```idris example
||| treeToList (listToTree [4,1,8,7,2,3,9,5,6])
||| ```
treeToList : Tree a -> List a
treeToList Empty = []
treeToList (Node l x r) = treeToList l ++ [x] ++ treeToList r

||| An integer arithmetic expression.
public export
data Expr = ||| A single integer.
            Val Int
          | ||| Addition of an expression to an expression.
            Add Expr Expr
          | ||| Subtraction of an expression from an expresison.
            Sub Expr Expr
          | ||| Multiplication of an expression with an expression.
            Mult Expr Expr

||| Evaluate an integer arithmetic expression.
|||
||| ```idris example
||| evaluate (Mult (Val 10) (Add (Val 6) (Val 3)))
||| ```
evaluate : Expr -> Int
evaluate (Val x)    = x
evaluate (Add x y)  = evaluate x + evaluate y
evaluate (Sub x y)  = evaluate x - evaluate y
evaluate (Mult x y) = evaluate x * evaluate y

||| Return the larger of two inputs, or `Nothing` if both inputs are `Nothing`.
|||
||| ```idris example
||| maxMaybe (Just 4) (Just 5)
||| ```
||| ```idris example
||| maxMaybe (Just 4) Nothing
||| ```
maxMaybe : Ord a => Maybe a -> Maybe a -> Maybe a
maxMaybe mx my = (max <$> mx <*> my) <|> mx <|> my

-- --------------------------------------------------------- [ 4.2.4 Exercises ]

public export
data PowerSource = Petrol
                 | Electricity
                 | Pedal

public export
data Vehicle : PowerSource -> Type where
     Unicycle : Vehicle Pedal
     Bicycle : Vehicle Pedal
     GalacticPizzaCar : Vehicle Electricity
     Motorcycle : (fuel : Nat) -> Vehicle Petrol
     Car : (fuel : Nat) -> Vehicle Petrol
     Bus : (fuel : Nat) -> Vehicle Petrol

||| Return the number of wheels on a vehicle.
|||
||| ```idris example
||| wheels GalacticPizzaCar
||| ```
wheels : Vehicle power -> Nat
wheels Unicycle         = 1
wheels Bicycle          = 2
wheels GalacticPizzaCar = 3
wheels (Motorcycle _)   = 2
wheels (Car _)          = 4
wheels (Bus _)          = 4

||| Refuel a petrol-powered vehicle.
|||
||| ```idris example
||| refuel (Car 0)
||| ```
refuel : Vehicle Petrol -> Vehicle Petrol
refuel (Motorcycle _) = Motorcycle  50
refuel (Car _)        = Car 100
refuel (Bus _)        = Bus 200
-- NOTE: refuel Unicycle impossible

||| Get the first n elements of a Vect.
|||
||| ```idris example
||| vectTake 3 [1,2,3,4,5,6,7]
||| ```
|||
||| @ n the number of elements to take
vectTake : (n : Nat) -> Vect (n + m) a -> Vect n a
vectTake Z _             = []
vectTake (S k) (x :: xs) = x :: vectTake k xs

||| Return `Just` the sum of the entries at position `pos` in each of the
||| inputs, if `pos` is within bounds, or `Nothing` otherwise.
|||
||| ```idris example
||| sumEntries 2 [1,2,3,4] [5,6,7,8]
||| ```
||| ```idris example
||| sumEntries 4 [1,2,3,4] [5,6,7,8]
||| ```
|||
||| @ pos a possibly out-of-bounds index into the input vectors
sumEntries : Num a => (pos : Integer) -> Vect n a -> Vect n a -> Maybe a
sumEntries {n} pos xs ys with (integerToFin pos n)
  | m = pure $ ((+) `on` index !m) xs ys

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


module ArithExp.SmallStep
import ArithExp.AST

||| Definition of a relation, adapted from *Software Foundations*
Relation : Type -> Type
Relation a = a -> a -> Type

deterministic : Relation a -> Type
deterministic {a=a} Ra = {x, y, z : a} -> Ra x y -> Ra x z -> y = z

||| Used or defining the "transitive closure" used in TAPL.
|||
||| This is also taken from *Software Foundations*
data MultiStep : Relation a -> Relation a where
  Reflexive   : MultiStep r x x
  Transitive  : r x y -> MultiStep r y z -> MultiStep r x z

syntax [x] THEN   [y] = x `Transitive` (y)
syntax [a] "=>>"  [b]  = SmallStep a b
syntax [a] "=>>*" [b]  = MultiStep SmallStep a b

||| 'SmallStep' is the small step OS relation
data SmallStep : ArithBool -> ArithBool -> Type where

  IfTrue     : (IF Tru a b)  =>> a

  IfFalse    : (IF Fals a b) =>> b

  IfStep     : (t =>> t')
            -> (IF t a b) =>> (IF t' a b)

  SuccStep   : (t =>> t')
            -> (Succ t) =>> (Succ t')

  IsZeroStep : (t =>> t')
            -> (IsZero t) =>> (IsZero t')

  IsZeroZero : (IsZero Zero) =>> Tru

  IsZeroSucc : {auto prf : NV n} -> (IsZero (Succ n)) =>> Fals

  PredStep   : (t =>> t')
            -> (Pred t) =>> (Pred t')

  PredZero   : (Pred Zero) =>> Zero

  PredSucc   : {prf : NV n} -> (Pred (Succ n)) =>> n

test1 : (IF (IF Tru Fals Fals) Tru (IsZero (Succ (Succ Zero)))) =>>* Fals
test1 = (IfStep IfTrue)   THEN
        IfFalse           THEN
        IsZeroSucc        THEN
        Reflexive


twoPlusTwoNotFive : 2 + 2 = 5 -> Void
twoPlusTwoNotFive Refl impossible

valueNotSuc : (x : Nat) -> x = S x -> Void
valueNotSuc _ Refl impossible


> module Identity.Properties

> import Control.Monad.Identity

> import Identity.Operations
> import Sigma.Sigma
> import Decidable.Predicates
> import Unique.Predicates
> import Finite.Predicates
> import Unit.Properties

> %default total

> %access public export

> ||| Id is injective
> injectiveId : {a : Type} -> {left : a} -> {right : a} -> (Id left) = (Id right) -> left = right
> injectiveId Refl = Refl
> %freeze injectiveId -- frozen

* |Identity| is a functor:

> -- functorSpec1 : fmap . id = id

> -- functorSpec2 : fmap (f . g) = (fmap f) . (fmap g)

* |Identity| is a monad:

> -- monadSpec1 : (fmap f) . ret = ret . f

> -- monadSpec21 : bind (ret a) f = f a

> -- monadSpec22 : bind ma ret = ma

> -- monadSpec23 : {A, B, C : Type} -> {f : A -> M B} -> {g : B -> M C} ->
> --                bind (bind ma f) g = bind ma (\ a => bind (f a) g)

* |Identity| is a container monad:

> |||
> elemNonEmptySpec0 : {A : Type} ->
>                     (a : A) -> (ia : Identity A) ->
>                     a `Elem` ia -> NonEmpty ia
> elemNonEmptySpec0 a (Id a) Refl = ()

> |||
> elemNonEmptySpec1 : {A : Type} ->
>                     (ia : Identity A) ->
>                     NonEmpty ia ->
>                     Sigma A (\ a => a `Elem` ia)
> elemNonEmptySpec1 (Id a) _ = (MkSigma a Refl)

> |||
> containerMonadSpec1 : {A : Type} -> {a : A} -> a `Elem` (ret a)
> containerMonadSpec1 {A} {a} = Refl

> -- containerMonadSpec2 : {A : Type} -> (a : A) -> (ma : M A) -> (mma : M (M A)) ->
> --                       a `Elem` ma -> ma `Elem` mma -> a `Elem` (join mma)

> -- containerMonadSpec2 : {A : Type} -> (a : A) -> (ma : M A) -> (mma : M (M A)) ->
> --                       a `Elem` ma -> ma `Elem` mma -> a `Elem` (join mma)

> containerMonadSpec3 : {A : Type} -> {P : A -> Type} ->
>                       (a : A) -> (ia : Identity A) -> All P ia -> a `Elem` ia -> P a
> containerMonadSpec3 {A} {P} a1 (Id a2) pa2 a1eqa2 = replace (sym a1eqa2) pa2

> -- containerMonadSpec4 : {A : Type} -> (ia : Identity A) -> fmap outl (tagElem ia) = ia

> -- containerMonadSpec5 : {A : Type} -> {P : A -> Type} ->
> --                       (ia : Identity A) -> ((a : A) -> a `Elem` ia -> P a) -> All P ia

* Specific container monad properties

> |||
> -- uniqueAllLemma : {A : Type} -> {P : A -> Type} ->
> --                  Unique1 P -> (ia : Identity A) -> Unique (All P ia)

> ||| All is finite
> finiteAll : {A : Type} -> {P : A -> Type} ->
>             Finite1 P -> (ia : Identity A) -> Finite (All P ia)
> finiteAll f1P (Id a) = f1P a

> ||| All is decidable
> decidableAll : {A : Type} -> {P : A -> Type} ->
>                (dec : (a : A) -> Dec (P a)) -> (ia : Identity A) -> Dec (All P ia)
> decidableAll dec ia = dec (unwrap ia)

> ||| NotEmpty is finite
> finiteNonEmpty : {A : Type} -> (ia : Identity A) -> Finite (NonEmpty ia)
> finiteNonEmpty _ = finiteUnit

> ||| NonEmpty is decidable
> decidableNonEmpty : {A : Type} -> (ia : Identity A) -> Dec (NonEmpty ia)
> decidableNonEmpty _ = Yes ()

> ||| Values of type |Identity A| are never empty
> nonEmptyLemma : {A : Type} -> (ia : Identity A) -> NonEmpty ia
> nonEmptyLemma (Id a) = elemNonEmptySpec0 a (Id a) Refl

> ||| |Elem| is decidable
> decElem : {A : Type} -> DecEq0 A -> (a : A) -> (ma : Identity A) -> Dec (a `Elem` ma)
> decElem dec a1 (Id a2) with (dec a1 a2)
>   | (Yes prf)   = Yes prf
>   | (No contra) = No contra
> %freeze decElem -- frozen

> ||| |Elem| is unique
> uniqueElem : {A : Type} -> UniqueEq0 A -> (a : A) -> (ma : Identity A) -> Unique (a `Elem` ma)
> uniqueElem unique a1 (Id a2) p q = unique a1 a2 p q
> %freeze uniqueElem -- frozen

> {-

These properties are already defined in base/Control/Monad/Identity.idr

> using (A : Type)
>   implementation (Eq A) => Eq (Identity A) where
>     (Id a) == (Id b) = a == b

> using (A : Type)
>   implementation (Show A) => Show (Identity A) where
>     show (Id a) = show a

> ---}


module Halfer

import public Numeric

%default total

||| Divide even integer by 2
public export
halfer : EvenInteger -> Integer
-- a: input integer
-- x: half of a
-- p: proof that x is the half of a
halfer (a ** (Factor (x ** p))) = cast x


import System
import Data.Vect

{- Toy program that outputs the n first digits of Pi.

   Inspired from http://www.haskell.org/haskellwiki/Shootout/Pidigits.
   The original ns and str lazy lists have been replaced by strict functions.

   Memory usage seems to be excessive. One of the branches of str is tail recursive, and
   the other one only needs to cons an extra Integer.

   For reference, the Haskell version runs in 0m0.230s when printing to /dev/null.
   It almost runs in constant space.
-}

data F = MkF Integer Integer Integer

-- Prints the list of digits by groups of 10
loop : Nat -> Nat -> List Integer -> IO ()
loop n k' Nil = putStrLn $ (pack $ Vect.replicate n ' ') ++ "\t:" ++ show k'
loop Z k' xs = do
    putStrLn ("\t:" ++ show k')
    loop 10 k' xs
loop (S k) k' (x::xs) = do
    putStr (show x)
    loop k (S k') xs

fn : Integer -> F
fn k = MkF k (4*k+2) (2*k+1)

flr : Integer -> F -> Integer
flr x (MkF q r t) = (q*x + r) `div` t

comp : F -> F -> F
comp (MkF q r t) (MkF u v x) = MkF (q*u) (q*v + r*x) (t*x)

-- Returns the list of digits of pi. Memory hungry.
str : F -> Integer -> Nat -> List Integer
str _ _ Z = Nil
str z k (S n) =
    if y == flr 4 z
        then y :: str (comp (MkF 10 (-10*y) 1) z    ) k     n
        else      str (comp z                 (fn k)) (k+1) (S n)
    where y = flr 3 z

main : IO ()
main = do
    arg <- getLine
    let n = fromInteger (cast arg)
    let l = str (MkF 1 0 1) 1 n
    loop 10 0 l
    pure ()


module ZipWithN

import Data.List
import Data.Vect

%default total

public export
interface ZipWithable f where
  zipWith : (a -> b -> c) -> f a -> f b -> f c

public export
ZipWithable List where
  zipWith = List.zipWith

public export
ZipWithable (Vect n) where
  zipWith = Vect.zipWith

namespace FunctionBased

  public export
  FunN : Vect n Type -> Type -> Type
  FunN []      ty = ty
  FunN (x::xs) ty = x -> FunN xs ty

  apFunN : {n : Nat} -> {0 args : Vect n Type} -> ZipWithable f => f $ FunN args res -> FunN (f <$> args) (f res)
  apFunN {n=Z}   {args=[]}    = id
  apFunN {n=S k} {args=a::as} = \fs, fa => apFunN $ zipWith apply fs fa

  public export
  zipWithN : {n : Nat} -> {0 args : Vect n Type} -> (ZipWithable m, Applicative m) => FunN args res -> FunN (m <$> args) (m res)
  zipWithN {n=Z}   {args=[]}    = pure
  zipWithN {n=S k} {args=a::as} = \f, xs => apFunN $ f <$> xs

namespace PseudoTypeclassBased_SearchBoth

  public export
  data FunN : (m : Type -> Type) -> ty -> mty -> Type where
    Constant : FunN m ty (m ty)
    Function : FunN m ty mty -> FunN m (a -> ty) (m a -> mty)

  apFunN : FunN m ty mty => ZipWithable m => m ty -> mty
  apFunN @{Constant}   = id
  apFunN @{Function s} = \fs, fa => apFunN $ zipWith apply fs fa

  public export
  zipWithN : FunN m ty mty => ZipWithable m => Applicative m => ty -> mty
  zipWithN @{Constant}   = pure
  zipWithN @{Function s} = \f, xs => apFunN $ f <$> xs


||| Views to show how a role interacts, or not, with a Term from a Global Type.
module Sessions.Global.Involved

import Decidable.Equality
import Data.List
import Data.List.Elem

import Data.List1

import Sessions.Meta
import Sessions.Global

%default total

public export
data Involved : (p, s, r : role)
                        -> Type
  where
    Sends : (prfS : role = s)
                 -> Involved role s r

    Recvs : (prfR : role = r)
                 -> Involved role s r

    Skips : (prfSNot : Not (role = s))
         -> (prfRNot : Not (role = r))
                    -> Involved role s r

public export
involved : DecEq role
        => (p, s, r : role)
        -> (contra  : Not (s = r))
                   -> Involved p s r
involved p s r contra with (decEq p s)
  involved p p r contra | (Yes Refl) = (Sends Refl)
  involved p s r contra | (No f) with (decEq p r)
    involved p s p contra | (No f) | (Yes Refl) = (Recvs Refl)
    involved p s r contra | (No f) | (No g) = (Skips f g)

-- [ EOF ]


import Data.Vect

data Format = Number Format
            | Str Format
            | Dble Format
            | Chr Format
            | Lit String Format
            | End

PrintfType : Format -> Type
PrintfType (Number fmt) = (i : Int) -> PrintfType fmt
PrintfType (Dble fmt) = (i : Double) -> PrintfType fmt
PrintfType (Str fmt) = (str: String) -> PrintfType fmt
PrintfType (Chr fmt) = (char : Char) -> PrintfType fmt
PrintfType (Lit str fmt) = PrintfType fmt
PrintfType End = String

printfFmt : (fmt : Format) -> (acc: String) -> PrintfType fmt
printfFmt (Number fmt) acc = \i => printfFmt fmt (acc ++ show i)
printfFmt (Dble fmt) acc = \i => printfFmt fmt (acc ++ show i)
printfFmt (Str fmt) acc = \str =>  printfFmt fmt (acc ++ str)
printfFmt (Chr fmt) acc = \char => printfFmt fmt (acc ++ show char)
printfFmt (Lit lit fmt) acc = printfFmt fmt (acc ++ lit)
printfFmt End acc = acc

toFormat : (xs : List Char) -> Format
toFormat [] = End
toFormat ('%' :: 'd' :: chars) = Number (toFormat chars)
toFormat ('%' :: 'f' :: chars) = Dble (toFormat chars)
toFormat ('%' :: 's' :: chars) = Str (toFormat chars)
toFormat ('%' :: 'c' :: chars) = Chr (toFormat chars)
toFormat ('%' :: chars) = Lit "%" (toFormat chars)
toFormat (c :: chars) = case toFormat chars of
                             Lit lit chars' => Lit (strCons c lit) chars'
                             fmt => Lit (strCons c "") fmt

printf : (fmt : String) -> PrintfType (toFormat (unpack fmt))
printf fmt = printfFmt _ ""

Matrix : Nat -> Nat -> Type
Matrix n m = Vect n (Vect m Double)


module Sphere

import Hittable
import Vec3
import Ray

%access export

public export

record Sphere where
    constructor MkSphere
    center : Vec3
    radius : Double

Hittable Sphere where
    hit sphere ray t_min t_max =
       if discriminant > 0
            then
                if temp < t_max && temp > t_min
                    then set_face_normal ray oNormal rec
                    else
                        if temp' < t_max && temp' > t_min
                            then set_face_normal ray oNormal' rec'
                            else MkHitRecord (0,0,0) (0,0,0) temp' False False
            else MkHitRecord (0,0,0) (0,0,0) 1 False False
    where
        oc : Vec3
        oc           = (orig ray) - center sphere
        a : Double
        a            = lengthSquared (dir ray)
        half_b : Double
        half_b       = dot oc (dir ray)
        c : Double
        c            = (lengthSquared oc) - radius sphere * radius sphere
        discriminant : Double
        discriminant = half_b*half_b - a*c

        root : Double
        root = sqrt discriminant
        temp : Double
        temp = (-half_b - root) / a
        temp' : Double
        temp' = (-half_b + root) / a

        rec_p : Vec3
        rec_p   = at ray temp
        rec : HitRecord
        rec     = MkHitRecord rec_p (0, 0, 0) temp False True
        oNormal : Vec3
        oNormal = (rec_p - center sphere) / radius sphere

        rec_p' : Vec3
        rec_p'   = at ray temp'
        rec' : HitRecord
        rec'     = MkHitRecord rec_p (0, 0, 0) temp' False True
        oNormal' : Vec3
        oNormal' = (rec_p' - center sphere) / radius sphere


isSingleton : Bool -> Type
isSingleton True  = Nat
isSingleton False = List Nat

mkSingle : (x : Bool) -> isSingleton x
mkSingle True = 0
mkSingle False = []

sum : (single : Bool) -> isSingleton single -> Nat
sum True  x       = x
sum False []      = 0
sum False (x::xs) = x + sum False xs


import Data.Vect

exactLength : (len : Nat) -> (input : Vect m a) -> Maybe (Vect len a)
exactLength {m} len input = case decEq m len of
                                 Yes Refl => Just input
                                 No contra => Nothing


||| Fixed point fractional number. - Ported from Haskell base.
|||
||| Copyright 2021, HATTORI, Hiroki
||| This file is released under the MIT license, see LICENSE for more detail.
|||
module Data.Fixed

import Data.Maybe
import Data.String

import Generics.Derive

import Data.Rational

%default total
%language ElabReflection

-- --------------------------------------------------------------------------

namespace ResolutionV

  public export
  data ResolutionV : Nat -> Type where
    MkResV : (n:Nat) -> (res:Integer) -> (res > 0 = True) -> ResolutionV n

  export expToResolution : (n:Nat) -> ResolutionV n
  expToResolution n = go 1 Refl n where
    go : (ans:Integer) -> (ans > 0 = True) -> (m:Nat) -> ResolutionV n
    go ans prf Z = MkResV n ans prf
    go ans prf (S m) = go (ans * 10) (believe_me $ Refl {x=True}) m

-- --------------------------------------------------------------------------

public export
data Fixed : Nat -> Type where
  MkFixed : Integer -> Fixed n

%runElab derive "Fixed" [Generic, Meta, Eq, Ord, DecEq]

public export
{n:Nat} -> Num (Fixed n) where
  (MkFixed x) + (MkFixed y) = MkFixed $ x + y
  (MkFixed x) * (MkFixed y) = let
    MkResV _ res _ = expToResolution n in MkFixed $ (x * y) `div` res
  fromInteger i = let
    MkResV _ res _ = expToResolution n in MkFixed $ i * res

public export
{n:Nat} -> Neg (Fixed n) where
  negate (MkFixed x) = MkFixed $ negate x
  (MkFixed x) - (MkFixed y) = MkFixed $ x - y

public export
{n:Nat} -> Abs (Fixed n) where abs (MkFixed x) = MkFixed $ abs x

partial public export
{n:Nat} -> Fractional (Fixed n) where
  (MkFixed x) / (MkFixed y) = let
    MkResV _ res _ = expToResolution n in MkFixed $ (x * res) `div` y
  recip (MkFixed x) = let
    MkResV _ res _ = expToResolution n in MkFixed $ (res * res) `div` x

public export
{n:Nat} -> Show (Fixed n) where
  show (MkFixed x) = if n == 0 then show x
                               else if x < 0 then "-" ++ go (negate x)
                               else go x where
    go : Integer -> String
    go x = let MkResV _ r _ = expToResolution n
               i = x `div` r
               d' = show $ x `mod` r
            in show i ++ "." ++ replicate (fromInteger $ cast $ cast n - strLength d') '0' ++ d'

-- --------------------------------------------------------------------------
-- Type cast

public export
{n:Nat} -> Cast Int (Fixed n) where
  cast i = let MkResV _ res _ = expToResolution n in MkFixed $ (cast i) * res
public export
{n:Nat} -> Cast Integer (Fixed n) where
  cast i = let MkResV _ res _ = expToResolution n in MkFixed $ i * res
public export
{n:Nat} -> Cast Rational (Maybe (Fixed n)) where
  cast x = let d = x.den
               MkResV _ res _ = expToResolution n
            in toMaybe (d == 0) $ MkFixed $ x.num * res `div` (natToInteger d)
public export
{n:Nat} -> Cast (Fixed n) Rational where
  cast (MkFixed x) = let
    MkResV _ res _ = expToResolution n in x %: res

-- --------------------------------------------------------------------------

public export resolution : {n:Nat} -> Fixed n -> Integer
resolution {n=n} _ = let MkResV _ res _ = expToResolution n in res

export div' : {n:Nat} -> Fixed n -> Fixed n -> Integer
div' {n=n} (MkFixed x) (MkFixed q) = x `div` q

export mod' : {n:Nat} -> Fixed n -> Fixed n -> Fixed n
mod' {n=n} (MkFixed x) (MkFixed q) = MkFixed $ x `mod` q

export scale : {n:Nat} -> Integer -> Fixed n -> Fixed n
scale {n=n} y (MkFixed x) = MkFixed $ x * y

-- --------------------------------------------------------------------------
-- vim: tw=80 sw=2 expandtab :


> module SequentialDecisionProblems.TabBackwardsInduction1

> import Data.Vect
> import Control.Isomorphism
> -- import Debug.Trace

> import SequentialDecisionProblems.CoreTheory
> import SequentialDecisionProblems.Utils

> import Nat.Operations
> import Nat.OperationsProperties
> import Nat.LTEProperties
> import Finite.Predicates
> import Finite.Operations
> import Finite.Properties
> import Decidable.Properties
> import Sigma.Sigma
> import Sigma.Operations
> import Pairs.Operations
> import Vect.Operations
> import Vect.Properties
> import Decidable.Predicates
> import Fin.Operations

> %default total
> %access public export
> -- %access export
> %auto_implicits off

* Tabulation

If the state space is finite

> finiteState : (t : Nat) -> Finite (State t)

, we can compute the number of values of type |State t| and collect them
in a vector

> cardState : (t : Nat) -> Nat
> cardState t = card (finiteState t)

> vectState : (t : Nat) -> Vect (cardState t) (State t)
> vectState t = toVect (finiteState t)

If |Reachable| and |Viable n| are also decidable

> decidableReachable : {t' : Nat} -> (x' : State t') -> Dec (Reachable x')

< decidableViable : {t : Nat} -> (n : Nat) -> (x : State t) -> Dec (Viable n x)

then their conjunction

> ReachableAndViable : {t : Nat} -> (n : Nat) -> (x : State t) -> Type
> ReachableAndViable n x = (Reachable x , Viable n x)

is decidable

> decidableReachableAndViable : {t : Nat} -> (n : Nat) -> (x : State t) -> Dec (ReachableAndViable n x)
> decidableReachableAndViable n x = decPair (decidableReachable x) (decidableViable n x)

and we can collect all states which are reachable and viable in a vector:

> cardReachableAndViableState : (t : Nat) -> (n : Nat) -> Nat
> cardReachableAndViableState t n = outl (f t n) where
>   f : (t : Nat) -> (n : Nat) -> Sigma Nat (\ m => Vect m (Sigma (State t) (ReachableAndViable n)))
>   f t n = filterTagSigma (decidableReachableAndViable n) (vectState t)

> vectReachableAndViableState : (t : Nat) -> (n : Nat) ->
>                               Vect (cardReachableAndViableState t n) (Sigma (State t) (ReachableAndViable n))
> vectReachableAndViableState t n = outr (f t n) where
>   f : (t : Nat) -> (n : Nat) -> Sigma Nat (\ m => Vect m (Sigma (State t) (ReachableAndViable n)))
>   f t n = filterTagSigma (decidableReachableAndViable n) (vectState t)

In this case, we can implement a "tabulated" versions of |bi| which is
linear in the number of decidion steps. Remember that |optExt| takes a
policy sequence for |n| steps and computes a policy sequence for |n + 1|
steps:

< optExt : {t, n : Nat} ->
<          (ps : PolicySeq (S t) n) -> Policy t (S n)

The idea is to replace the |ps| argument of |optExt| with a "value
table" |vt : Vect (cardReachableAndViableState t n) Val| storing the
value, for every state in |vectReachableAndViableState (S t) n|, of
taking |n| decision steps with |ps| starting from that state. Also ...

> |||
> PolicyTable : (t : Nat) -> (n : Nat) -> Type
> PolicyTable t  Z    = Unit
> PolicyTable t (S m) = Vect
>                       (cardReachableAndViableState t (S m))
>                       (Sigma (State t) (\x => (ReachableAndViable (S m) x, GoodCtrl t x m)))

> |||
> data PolicyTableSeq : (t : Nat) -> (n : Nat) -> Type where
>   Nil   :  {t : Nat} ->
>            PolicyTableSeq t Z
>   (::)  :  {t, n : Nat} ->
>            PolicyTable t (S n) -> PolicyTableSeq (S t) n -> PolicyTableSeq t (S n)

> |||
> ValueTable : Nat -> Nat -> Type
> ValueTable t n = Vect (cardReachableAndViableState t n) Val

> |||
> tabOptExt : {t, n : Nat} ->
>             (vt : ValueTable (S t) n) ->
>             -- (vt : Vect (cardReachableAndViableState (S t) n) Val) ->
>             PolicyTable t (S n)

We implement |tabOptExt| on the basis of the implementation of |optExt|
of the core theory. We start with a tabulated version of |sval|:

> tabSval : {t,n : Nat} ->
>         (x  : State t) -> .(r  : Reachable x) -> .(v  : Viable (S n) x) ->
>         (gy  : GoodCtrl t x n) ->
>         (vt : Vect (cardReachableAndViableState (S t) n) Val) ->
>         PossibleNextState x (ctrl gy) -> Val
> tabSval {t} {n} x r v gy vt (MkSigma x' x'emx') =
>   let y    : Ctrl t x
>            = ctrl gy in
>   let mx'  : M (State (S t))
>            = nexts t x y in
>   let ar'  : All Reachable mx'
>            = reachableSpec1 x r y in
>   let av'  : All (Viable n) mx'
>            = allViable gy in
>   let r'   : Reachable x'
>            = allElemSpec0 x' mx' ar' x'emx' in
>   let v'   : Viable n x'
>            = allElemSpec0 x' mx' av' x'emx' in
>   let rvxs : Vect (cardReachableAndViableState (S t) n) (State (S t))
>            = map outl (vectReachableAndViableState (S t) n) in
>   let dRV  : ((x' : State (S t)) -> Dec (ReachableAndViable n x'))
>            = decidableReachableAndViable n in
>   let prf  : Elem x' (vectState (S t))
>            = toVectComplete (finiteState (S t)) x' in
>   let prf' : Elem x' rvxs
>            = filterTagSigmaLemma {P = ReachableAndViable n} dRV x' (vectState (S t)) prf (r',v') in
>   let k    : Fin (cardReachableAndViableState (S t) n)
>            -- = trace ("Lookup " ++ show n) (lookup x' rvxs prf') in
>            = lookup x' rvxs prf' in
>   reward t x y x' `plus` index k vt

Next, we implement a tabulated version of |cval|:

> tabCval : {t, n : Nat} ->
>         (x  : State t) -> .(r  : Reachable x) -> .(v  : Viable (S n) x) ->
>         (vt : Vect (cardReachableAndViableState (S t) n) Val) ->
>         GoodCtrl t x n -> Val
> tabCval {t} x r v vt gy = let y    : Ctrl t x
>                                  = ctrl gy in
>                         let mx'  : M (State (S t))
>                                  = nexts t x y in
>                         meas (fmap (tabSval x r v gy vt) (tagElem mx'))

And finally

> tabCvalargmax : {t, n : Nat} ->
>               (x  : State t) -> .(r : Reachable x) -> .(v : Viable (S n) x) ->
>               (vt : Vect (cardReachableAndViableState (S t) n) Val) -> GoodCtrl t x n

> {-
> tabOptExt {t} {n} vt = pt where
>   pt : PolicyTable t (S n)
>   pt = toVect ptf where
>     ptf : Fin (cardReachableAndViableState t (S n)) -> (Sigma (State t) (\x => (ReachableAndViable (S n) x, GoodCtrl t x n)))
>     ptf k = MkSigma x (rv, gy) where
>       xrv : Sigma (State t) (ReachableAndViable (S n))
>       xrv = index k (vectReachableAndViableState t (S n))
>       x   : State t
>       x   = outl xrv
>       rv  : ReachableAndViable (S n) x
>       rv  = outr xrv
>       gy  : GoodCtrl t x n
>       gy  = tabCvalargmax x (fst rv) (snd rv) vt
> -}
> tabOptExt {t} {n} vt =
>   let xrv -- : ((k : Fin (cardReachableAndViableState t (S n))) -> Sigma (State t) (ReachableAndViable (S n)))
>           = \ k => index k (vectReachableAndViableState t (S n)) in
>   let x   : ((k : Fin (cardReachableAndViableState t (S n))) -> State t)
>           = \ k => outl (xrv k) in
>   let rv  -- : ((k : Fin (cardReachableAndViableState t (S n))) -> ReachableAndViable (S n) (x k))
>           = \ k => outr (xrv k) in
>   let gy  -- : ((k : Fin (cardReachableAndViableState t (S n))) -> GoodCtrl t (x k) n)
>           = \ k => tabCvalargmax (x k) (fst (rv k)) (snd (rv k)) vt in
>   let ptf -- : ((k : Fin (cardReachableAndViableState t (S n))) -> (Sigma (State t) (\ x => (ReachableAndViable (S n) x, GoodCtrl t x n))))
>           = \ k => MkSigma (x k) (rv k, gy k) in
>   let pt  : PolicyTable t (S n)
>           = toVect ptf in
>   pt

* Tabulated tail-recursive backwards induction

With |tabOptExt| in place, it is easy to implement a tabulated version of
|trbi|:

> |||
> PolicySeqAndTab : Nat -> Nat -> Type
> PolicySeqAndTab t n = (PolicySeq t n, ValueTable t n)

> |||
> zeroVec : (n : Nat) -> Vect n Val
> zeroVec Z     = Nil
> zeroVec (S n) = zero :: zeroVec n

> ||| Tabulated tail-recursive backwards induction iteration
> ttrbii : (t : Nat) -> (n : Nat) -> (c : Nat) -> (LTE c n) ->
>          PolicyTableSeq (c + t) (n - c) ->
>          (vt : Vect (cardReachableAndViableState (c + t) (n - c)) Val) ->
>          PolicyTableSeq t n
>
> ttrbii t n  Z     prf pts vt = replace {P = \ z => PolicyTableSeq t z} (minusZeroRight n) pts
> {-
> ttrbii t n (S c') prf pts vt = ttrbii t n c' prf' pts' vt'' where
>   bic  : S (n - S c') = n - c'
>   bic  = minusLemma4 prf
>   prf' : LTE c' n
>   prf' = lteLemma1 c' n prf
>   pt   : PolicyTable (c' + t) (S (n - S c'))
>   pt   = tabOptExt vt
>   pts' : PolicyTableSeq (c' + t) (n - c')
>   pts' = replace {P = \ z => PolicyTableSeq (c' + t) z} bic (pt :: pts)
>   vt'  : Vect (cardReachableAndViableState (c' + t) (S (n - S c'))) Val
>   vt'  = toVect vt'f where
>     vt'f : Fin (cardReachableAndViableState (c' + t) (S (n - S c'))) -> Val
>     vt'f k = tabCval x r v vt gy where
>       xrvgy : Sigma (State (c' + t)) (\ x => (ReachableAndViable (S (n - S c')) x, GoodCtrl (c' + t) x (n - S c')))
>       xrvgy = index k pt
>       x     : State (c' + t)
>       x     = outl xrvgy
>       rv    : ReachableAndViable (S (n - S c')) x
>       rv    = fst (outr xrvgy)
>       r     : Reachable x
>       r     = fst rv
>       v     : Viable (S (n - S c')) x
>       v     = snd rv
>       gy    : GoodCtrl (c' + t) x (n - S c')
>       gy    = snd (outr xrvgy)
>   vt''  : Vect (cardReachableAndViableState (c' + t) (n - c')) Val
>   vt''  = replace {P = \z => Vect (cardReachableAndViableState (c' + t) z) Val} bic vt'
> -}
> ttrbii t n (S c') prf pts vt =
>   let bic   : (S (n - S c') = n - c')
>             = minusLemma4 prf in
>   let prf'  : LTE c' n
>             = lteLemma1 c' n prf in
>   let pt    : PolicyTable (c' + t) (S (n - S c'))
>             = tabOptExt vt in
>   let pts'  : PolicyTableSeq (c' + t) (n - c')
>             = replace {P = \ z => PolicyTableSeq (c' + t) z} bic (pt :: pts) in
>   let xrvgy -- : ((k : Fin (cardReachableAndViableState (c' + t) (S (n - S c')))) ->
>             --    Sigma (State (c' + t)) (\ x => (ReachableAndViable (S (n - S c')) x, GoodCtrl (c' + t) x (n - S c'))))
>             = \ k => index k pt in
>   let x     : ((k : Fin (cardReachableAndViableState (c' + t) (S (n - S c')))) -> State (c' + t))
>             = \ k => outl (xrvgy k) in
>   let rv    -- : ((k : Fin (cardReachableAndViableState (c' + t) (S (n - S c')))) -> ReachableAndViable (S (n - S c')) (x k))
>             = \ k => fst (outr (xrvgy k)) in
>   let r     : ((k : Fin (cardReachableAndViableState (c' + t) (S (n - S c')))) -> Reachable {t' = c' + t} (x k))
>             = \ k => fst (rv k) in
>   let v     : ((k : Fin (cardReachableAndViableState (c' + t) (S (n - S c')))) -> Viable {t = c' + t} (S (n - S c')) (x k))
>             = \ k => snd (rv k) in
>   let gy    : ((k : Fin (cardReachableAndViableState (c' + t) (S (n - S c')))) -> GoodCtrl (c' + t) (x k) (n - S c'))
>             = \ k => snd (outr (xrvgy k)) in
>   let vt'f  : ((k : Fin (cardReachableAndViableState (c' + t) (S (n - S c')))) -> Val)
>             = \ k => tabCval (x k) (r k) (v k) vt (gy k) in
>   let vt'   : Vect (cardReachableAndViableState (c' + t) (S (n - S c'))) Val
>             = toVect vt'f in
>   let vt''  : Vect (cardReachableAndViableState (c' + t) (n - c')) Val
>             = replace {P = \z => Vect (cardReachableAndViableState (c' + t) z) Val} bic vt' in
>   ttrbii t n c' prf' pts' vt''

> ||| Tabulated tail-recursive backwards induction
> tabTailRecursiveBackwardsInduction1 : (t : Nat) -> (n : Nat) -> PolicyTableSeq t n
> tabTailRecursiveBackwardsInduction1 t n = ttrbii t n n (reflexiveLTE n) zps (zeroVec _) where
>   zps : PolicyTableSeq (n + t) (n - n)
>   zps = replace {P = \ z => PolicyTableSeq (n + t) z} (minusZeroN n) Nil

> {-

> ---}


module EDSL

--import TypeTrans.AST
import TypeTrans.Transformations
import TypeTrans.Array
import Control.Monad.State

import Data.Vect

data TypeT = TyInt | TyBool | TyFun TypeT TypeT | TyVect Nat TypeT

-- Difference between stream and seq?
data MapVariant = MSeq | MPar | MStream
data FoldVariant = FSeq | FStream | FTree

total
interpType : TypeT -> Type
interpType TyInt = Int
interpType TyBool = Bool
interpType (TyFun i o) = interpType i -> interpType o
interpType (TyVect i t) = Vect i (interpType t)

-- Locate "base"/primitive type e.g. int, bool
--total
--baseType : TypeT -> TypeT
--baseType (TyFun i o) =
--baseType TyVect Nat

using (G : Vect xs TypeT) {

data HasType : Fin n -> Vect n TypeT -> TypeT -> Type where
  Stop : HasType FZ (t :: G) t
  Pop  : HasType k G t -> HasType (FS k) (u :: G) t

data Expr : (Vect xs TypeT) -> TypeT -> Type where
  Var : HasType i G t -> Expr G t
  Val : (x : Int) -> Expr G TyInt
  Map : MapVariant -> Expr G (TyFun a b) -> Expr G (TyVect n a) -> Expr G (TyVect n b)

  -- Treat Composition as Concatonation of multiple Applys in a row
  -- Apply f (Apply g o)  is a composition of f and g, can be used for
  -- map streaming optimisation
  Apply : Expr G (TyFun a b) -> Expr G a -> Expr G b
  --Let : Expr (a :: gam) (Val () :: gam’) (R t) -> Expr gam gam’ t

  FoldL : FoldVariant -> Expr G (TyFun a (TyFun b a)) ->
                          Expr G a  -> Expr G (TyVect n b) -> Expr G a
  FoldR : FoldVariant -> Expr G (TyFun a (TyFun b b)) ->
                          Expr G b  -> Expr G (TyVect n a) -> Expr G b

  -- For Assoc Fold, the function needs to be closed e.g. (a -> a -> a), possibly
  -- ensure given type is a monoid and use the respective monoid function for that type,
  -- using implicit type class instances we can select which monoid we wish to use
  -- e.g. the natural numbers can create a monoid instance for both addition and multiplication
  --FoldAssoc : (Monoid (interpType a)) => FoldVariant -> Expr G a -> Expr G (TyVect n a) -> Expr G a

  Lambda : Expr (a :: G) t -> Expr G (TyFun a t)
  --Compose : Expr G (TyFun a  -> Expr (head a

  Split : (m: Nat) -> Expr G (TyVect n t) ->
                      {default SIsNotZ nz : Not (m = Z)} ->
                      {auto mz : modNatNZ n m nz = Z} ->
                      Expr G (TyVect m (TyVect (divNatNZ n m nz) t))

  Merge : Expr G (TyVect x1 (TyVect x2 t)) -> Expr G (TyVect (x1 * x2) t)
  Op : (interpType a -> interpType b -> interpType c) -> Expr G a -> Expr G b -> Expr G c
  UnOp : (interpType a -> interpType b) -> Expr G a -> Expr G b

-- Idris Interpreter which executes the AST

-- When we produce an expression we need to know which variables are in scope,
-- as well as their types. Env is an environment indexed over the types in scope.
data Env : Vect n TypeT -> Type where
  Nil : Env Nil
  (::) : interpType a -> Env G -> Env (a :: G)

lookup : HasType i G t -> Env G -> interpType t
lookup Stop (x :: xs) = x
lookup (Pop k) (x :: xs) = lookup k xs

interp : Env G -> Expr G t -> interpType t
interp env (Var i) = lookup i env
interp env (Val x) = x
interp env (Apply f s) = (interp env f) (interp env s)
interp env (Lambda body) = \x => interp (x :: env) body
interp env (Map vt f xs) =
  case (interp env xs) of
    [] => Nil
    (y::ys) => (interp env (Apply f (UnOp head xs))) :: (interp env (Map vt f (UnOp tail xs)))

interp env (FoldL vt f x xs) =
  case (interp env xs) of
    [] => interp env x
    (y::ys) => interp env $ FoldL vt f (Apply (Apply f x) $ UnOp head xs) $ UnOp tail xs

interp env (FoldR vt f x xs) =
  case (interp env xs) of
    [] => interp env x
    (y::ys) => interp env $ Apply (Apply f $ UnOp head xs) (FoldR vt f x $ UnOp tail xs)

--interp env (FoldAssoc vt f x xs) = interp env (FoldL vt f x xs)

interp env (Op op x y) = op (interp env x) (interp env y)
interp env (UnOp op x) = op (interp env x)
--interp env (Merge xs) = merge $ interp env xs
--interp env (Split m xs {nz} {mz}) = splitV m {nz} {mz} $ interp env xs

-- Generate All Different Combinations
generate : Env G -> Expr G t -> Expr G t
generate env (Var i) = (Var i)
generate env (Val x) = (Val x)
generate env (Apply f s) = Apply (convertS env f) (convertS env s)
generate env (Lambda body) = Lambda (convertS body)
generate env (Map vt f xs) = ?todo45
--  case (interp env xs) of
--    [] => Nil
--    (y::ys) => (interp env (Apply f (UnOp head xs))) :: (interp env (Map vt f (UnOp tail xs)))
generate env (FoldL vt f x xs) = ?todo57
--  case (interp env xs) of
--    [] => interp env x
--    (y::ys) => interp env $ FoldL vt f (Apply (Apply f x) $ UnOp head xs) $ UnOp tail xs

generate env (FoldR vt f x xs) = ?todo56
--  case (interp env xs) of
--    [] => interp env x
--    (y::ys) => interp env $ Apply (Apply f $ UnOp head xs) (FoldR vt f x $ UnOp tail xs)

--interp env (FoldAssoc vt f x xs) = interp env (FoldL vt f x xs)

interp env (Op op x y) = Op op (generate env x) (generate env y)
interp env (UnOp op x) = UnOp op (generate env x)

mkLam : TTName -> Expr (t::g) t' -> Expr g (TyFun t t')
mkLam _ body = Lambda body

-- Specify structures for DSL
dsl expr
  lambda = mkLam
  variable = Var
  index_first = Stop
  index_next = Pop
  variable = Var

pure : Expr G a -> Expr G a
pure = id

(<$>) : (f : Lazy (Expr G (TyFun a t))) -> Expr G a -> Expr G t
(<$>) f a = Apply f a

-- Examples:
syntax "map" [f] [xs] = Map MSeq f xs
syntax [x] "+" [y] = Op (+) x (Val y)

-- AST for lambda function which adds 3 to a given integer
add3 : Expr G (TyFun TyInt TyInt)
add3 = Lambda (Op (+) (Var Stop) (Val 3))

add3Pretty : Expr G (TyFun TyInt TyInt)
add3Pretty = expr (\x => Op (+) (Val 3) x)

add3Pretty2 : Expr G (TyFun TyInt TyInt)
add3Pretty2 = expr (\x => x + 3)

-- AST for lambda function which adds 2 integers
add : Expr G (TyFun TyInt (TyFun TyInt TyInt))
add = Lambda (Lambda (Op (+) (Var Stop) (Var (Pop Stop))))

addPretty : Expr G (TyFun TyInt (TyFun TyInt TyInt))
addPretty = expr (\x,y => (Op (+) x y))

-- AST for simple mapping over list
mapAdd3 : Expr G (TyFun (TyVect n TyInt) (TyVect n TyInt))
mapAdd3 = Lambda (Map MSeq (add3) (Var Stop))

mapAdd3Pretty : Expr G (TyFun (TyVect n TyInt) (TyVect n TyInt))
mapAdd3Pretty = expr (\xs => map add3 xs)

-- AST for simple merge and mapping
map2dAdd3 : Expr G (TyFun (TyVect m (TyVect n TyInt)) (TyVect (m * n) TyInt))
map2dAdd3 = Lambda (Apply (mapAdd3) (Merge (Var Stop)))

testAdd : Int ->  Expr G (TyFun TyInt TyInt)
testAdd i = Lambda (Op (+) (Var Stop) (Val i))

testAdd' : {n : Nat} -> Vect n t ->  Expr G (TyFun TyInt TyInt)
testAdd' v {n} = Lambda (Op (+) (Var Stop) (Val $ fromNat n))

--splitEx : Expr G (TyFun (TyVect (m * n) TyInt) (TyVect m (TyVect n TyInt)))
--splitEx {m = Z} = ?todo45 --Lambda (Var Stop)
--splitEx {m = S k} {n} = rewrite (modMProof m n) in (Lambda (Split m (Var Stop)))

--AST for merge, map, then split again
--mapAddSplit : Expr G (TyFun (TyVect m (TyVect n TyInt)) (TyVect m (TyVect n TyInt)))
--mapAddSplit {m = Z} = Lambda (Var Stop)
--mapAddSplit {m = S k} = Lambda (Split m $ Apply (mapAdd3) (Merge (Var Stop)))

{-
print2dV : Vect m (Vect n Int) -> IO ()
print2dV xs =
    do print "["
       print2dV' xs

  where print2dV' : Vect m (Vect n Int) -> IO ()
        print2dV' [] = print "]"
        print2dV' (x::[]) = do print x
                               print "]"

        print2dV' (x::xs) = do print x
                               print ", "
                               print2dV' xs

-}

interpStuff : IO ()
interpStuff = do
    print $ interp [] mapAdd3 [1,2,3,4]
    print v2d

    print v3

  where v2d : Vect 3 Int
        v2d = interp [] map2dAdd3 [[1,1,1]]

        v3 : Int
        v3 = interp [] add3 3
}


module Naturality

import public TypesAndFunctions
import public Category
import public Isomorphism

%default total

public export
Naturality : {cat : Category} -> {a, b, x, y : Object cat} ->
  (f : Morphism cat a b) -> (g : Morphism cat y x) ->
  (preCompose {cat} {a=y} {b=x} {c=b} g) .
    (postCompose {cat} {a=x} {b=a} {c=b} f) =
  (postCompose {cat} {a=y} {b=a} {c=b} f) .
    (preCompose {cat} {a=y} {b=x} {c=a} g)
Naturality f g =
  functionalExtensionality (\h : Morphism cat x a => Associativity cat f h g)

public export
SubjectChange : {cat : Category} -> (subjectA, subjectB : Object cat) -> Type
SubjectChange {cat} subjectA subjectB =
  (observer : Object cat) ->
  Morphism cat observer subjectA -> Morphism cat observer subjectB

public export
ObserverChange : {cat : Category} -> (observerA, observerB : Object cat) -> Type
ObserverChange {cat} observerA observerB =
  (subject : Object cat) ->
  Morphism cat observerA subject -> Morphism cat observerB subject

public export
InvertibleSubjectChange : {cat : Category} ->
  (subjectA, subjectB : Object cat) -> Type
InvertibleSubjectChange subjectA subjectB =
  DPair (SubjectChange subjectA subjectB) IsBijectionForEach

public export
InvertibleObserverChange : {cat : Category} ->
  (observerA, observerB : Object cat) -> Type
InvertibleObserverChange observerA observerB =
  DPair (ObserverChange observerA observerB) IsBijectionForEach

public export
SubjectChangeIsNatural : {cat : Category} ->
  {subjectA, subjectB : Object cat} ->
  SubjectChange {cat} subjectA subjectB -> Type
SubjectChangeIsNatural {cat} alpha =
  (x, y : Object cat) -> (g : Morphism cat y x) ->
    alpha y . preCompose g = preCompose g . alpha x

public export
ObserverChangeIsNatural : {cat : Category} ->
  {observerA, observerB : Object cat} ->
  ObserverChange {cat} observerA observerB -> Type
ObserverChangeIsNatural {cat} beta =
  (x, y : Object cat) -> (g : Morphism cat x y) ->
    postCompose g . beta x = beta y . postCompose g

public export
SubjectChangeInducedMorphism : {cat : Category} ->
  {subjectA, subjectB : Object cat} ->
  (alpha : SubjectChange {cat} subjectA subjectB) ->
  Morphism cat subjectA subjectB
SubjectChangeInducedMorphism {subjectA} {subjectB} alpha =
  alpha subjectA (catId subjectA)

public export
SubjectChangeIsPostComposition : {cat : Category} ->
  {subjectA, subjectB : Object cat} ->
  (alpha : SubjectChange {cat} subjectA subjectB) ->
  (natural : SubjectChangeIsNatural {cat} {subjectA} {subjectB} alpha) ->
  (x : Object cat) -> alpha x =
    postCompose {cat} {a=x} {b=subjectA} {c=subjectB}
      (SubjectChangeInducedMorphism {cat} {subjectA} {subjectB} alpha)
SubjectChangeIsPostComposition {subjectA} {subjectB} alpha natural x =
  functionalExtensionality (\g =>
    replace
      {p=(\g' =>
        alpha x g' = After cat (alpha subjectA (Identity cat subjectA)) g)}
    (LeftIdentity cat g)
    (appEq {x=(catId subjectA)} (natural _ _ g)))

public export
ObserverChangeInducedMorphism : {cat : Category} ->
  {observerA, observerB : Object cat} ->
  (beta : ObserverChange {cat} observerA observerB) ->
  Morphism cat observerB observerA
ObserverChangeInducedMorphism {observerA} {observerB} beta =
  beta observerA (catId observerA)

public export
ObserverChangeIsPreComposition : {cat : Category} ->
  {observerA, observerB : Object cat} ->
  (beta : ObserverChange {cat} observerA observerB) ->
  (natural : ObserverChangeIsNatural {cat} {observerA} {observerB} beta) ->
  (y : Object cat) -> beta y =
    preCompose {cat} {a=observerB} {b=observerA} {c=y}
      (ObserverChangeInducedMorphism {cat} {observerA} {observerB} beta)
ObserverChangeIsPreComposition {observerA} {observerB} beta natural y =
  functionalExtensionality (\f =>
    replace
      {p=(\f' =>
        beta y f' = After cat f (beta observerA (Identity cat observerA)))}
    (RightIdentity cat f)
    (sym (appEq {x=(catId observerA)} (natural _ _ f))))

public export
NaturalBijectiveSubjectChangeInducesIsomorphism :
  {cat : Category} ->
  {subjectA, subjectB : Object cat} ->
  (alpha : SubjectChange {cat} subjectA subjectB) ->
  (natural : SubjectChangeIsNatural {cat} {subjectA} {subjectB} alpha) ->
  (bijective : IsBijectionForEach alpha) ->
  IsIsomorphism {cat} {a=subjectA} {b=subjectB}
    (SubjectChangeInducedMorphism {cat} {subjectA} {subjectB} alpha)
NaturalBijectiveSubjectChangeInducesIsomorphism
  {subjectA} {subjectB} alpha natural bijective =
    let
      bRight = snd (ForEachInverseIsInverse bijective subjectB) (catId subjectB)
    in
    ((fst (bijective subjectB) (Identity cat subjectB)) **
     (HasLeftInverseImpliesInjective
        {f=(alpha subjectA)} {g=(fst (bijective subjectA))}
        {x=(After cat
          (fst (bijective subjectB) (Identity cat subjectB))
          (alpha subjectA (Identity cat subjectA)))}
        {x'=(catId subjectA)}
        (fst (ForEachInverseIsInverse bijective subjectA))
        (trans
          (replace
            {p=
              (\g' =>
                alpha subjectA
                  (After cat
                     (fst (bijective subjectB) (Identity cat subjectB))
                       (alpha subjectA (Identity cat subjectA))) =
                     After cat g' (alpha subjectA (Identity cat subjectA)))}
                     bRight
                     (appEq
                       {x=(fst (bijective subjectB) (Identity cat subjectB))}
                       (natural _ _ (alpha _ (catId subjectA)))))
          (LeftIdentity cat (alpha subjectA (Identity cat subjectA)))),
      (trans
        (replace
          {p=
            (\g' =>
              After cat
                (alpha subjectA (Identity cat subjectA))
                   (fst (bijective subjectB) (Identity cat subjectB)) =
                      alpha subjectB g')}
           (LeftIdentity cat (fst (bijective subjectB) (Identity cat subjectB)))
           (sym
             (appEq {x=(catId subjectA)}
             (natural _ _ (fst (bijective subjectB) (catId subjectB))))))
        bRight)))

public export
NaturalBijectiveObserverChangeInducesIsomorphism :
  {cat : Category} ->
  {observerA, observerB : Object cat} ->
  (beta : ObserverChange {cat} observerA observerB) ->
  (natural : ObserverChangeIsNatural {cat} {observerA} {observerB} beta) ->
  (bijective : IsBijectionForEach beta) ->
  IsIsomorphism {cat} {a=observerB} {b=observerA}
    (ObserverChangeInducedMorphism {cat} {observerA} {observerB} beta)
NaturalBijectiveObserverChangeInducesIsomorphism
  {observerA} {observerB} beta natural bijective =
    let
      bRight =
        snd (ForEachInverseIsInverse bijective observerB) (catId observerB)
    in
    (fst (bijective observerB) (catId observerB) **
     (trans
       (replace
          {p=
            (\g' =>
              After cat
                (fst (bijective observerB) (Identity cat observerB))
                (beta observerA (Identity cat observerA)) =
              beta observerB g'
            )}
          (RightIdentity cat
            (fst (bijective observerB) (Identity cat observerB)))
          (appEq {x=(catId observerA)}
             (natural _ _ (fst (bijective observerB) (catId observerB))))
      ) bRight,
      HasLeftInverseImpliesInjective
        {f=(beta observerA)} {g=(fst (bijective observerA))}
        (fst (ForEachInverseIsInverse bijective observerA))
        (trans (sym (
           replace
             {p=(\g' =>
                   After cat (beta observerA (Identity cat observerA)) g' =
                   beta observerA (After cat
                     (beta observerA (Identity cat observerA))
                      (fst (bijective observerB) (Identity cat observerB))))}
             bRight
             (appEq {x=(fst (bijective observerB) (catId observerB))}
              (natural _ _ (beta _ (catId observerA))))
        )) (RightIdentity cat _))))


data InfList : Type -> Type where
     (::) : (value : elem) -> Inf (InfList elem) -> InfList elem

%name InfList xs, ys, zs

countFrom : Integer -> InfList Integer
countFrom x = x :: Delay (countFrom (x + 1))

getPrefix : (count : Nat) -> InfList a -> List a
getPrefix Z xs = []
getPrefix (S k) (value :: xs) = value :: getPrefix k xs

labelWith : InfList Integer -> List a -> List (Integer, a)
labelWith (lbl :: lbls) [] = []
labelWith (lbl :: lbls) (val :: vals) = (lbl, val) :: labelWith lbls vals

label : List a -> List (Integer, a)
label = labelWith (countFrom 0)


import Data.List.Views

palindrome : Eq a => List a -> Bool
palindrome xs with (vList xs)
  palindrome [] | VNil = True
  palindrome [x] | VOne = True
  palindrome (x :: (ys ++ [y])) | (VCons rec)
    = if x == y
      then palindrome ys | rec
      else False


module LittleLang
-- Warning: only briefly tested, may have bugs

-- a Type, Naturals, Booleans and iterated function types built from these
public export
data Ty : Type where
  NT : Ty
  BT : Ty
  FT : Ty -> Ty -> Ty

-- An expression with type
public export
data Exp : Ty -> Type where
  N : Nat -> Exp NT  -- a literal natural number
  B : Bool -> Exp BT -- a literal boolean
  LTE : Exp NT -> Exp NT -> Exp BT
  EQ : Exp NT -> Exp NT -> Exp BT
  If : {a: Ty} ->  Exp BT -> Exp a -> Exp a -> Exp a -- if expression
  Var : (name: String) -> (type: Ty) -> Exp type -- a variable
  Lam : {domain: Ty} ->  -- a lambda expression defining a function
            {codomain: Ty} -> (var : Exp domain) ->
            (value : Exp codomain) -> Exp (FT domain codomain)
  App : (a: Ty) -> (b: Ty)  ->  -- function application
            (f : Exp (FT a b)) -> (arg: Exp a) -> Exp b
  Sum :  Exp NT -> Exp NT -> Exp NT
  Prod: Exp NT -> Exp NT -> Exp NT
  Pred: Exp NT -> Exp NT -- predecessor of a natural number

-- An example
not: Exp (FT BT BT)
not = Lam (Var "x" BT) (If (Var "x" BT) (B False) (B True))

-- If `a == b` returns an expression of type `a` as one of type `b`
mapTyp : (a : Ty) -> (b: Ty) -> Exp a -> Maybe (Exp b)
mapTyp NT NT x = Just x
mapTyp NT BT x = Nothing
mapTyp NT (FT y z) x = Nothing
mapTyp BT NT x = Nothing
mapTyp BT BT x = Just x
mapTyp BT (FT y z) x = Nothing
mapTyp (FT y z) NT x = Nothing
mapTyp (FT y z) BT x = Nothing
mapTyp (FT y z) (FT w s) (If x t u) =
  case (mapTyp (FT y z) (FT w s) t) of
    Nothing => Nothing
    (Just q) => (case (mapTyp (FT y z) (FT w s) u) of
         Nothing => Nothing
         (Just p) => Just (If x q p))
mapTyp (FT y z) (FT w s) (Var name (FT y z)) =
  if (isJust (mapTyp y w (Var name y))) && (isJust (mapTyp z s (Var name z)))
    then Just(Var name (FT w s)) else Nothing
mapTyp (FT y z) (FT w s) (Lam var value) =
  case (mapTyp y w var) of
      Nothing => Nothing
      (Just x) => (case (mapTyp z s value) of
                        Nothing => Nothing
                        (Just p) => Just (Lam x p))
mapTyp (FT y z) (FT w s) (App a (FT y z) f arg) =
  (case mapTyp (FT a (FT y z)) (FT a (FT w s)) f of
        Nothing => Nothing
        (Just g) =>
          Just(App a (FT w s) g arg)
        )

-- equality of types
export
eqTyp : Ty -> Ty -> Bool
eqTyp x y = isJust (mapTyp x y (Var "test" x))

-- substitute `x` by `y` in `base`
subs: (a: Ty) -> (b: Ty) -> (base: Exp a) -> (x: Exp b) -> (y: Exp b) -> Exp a
subs NT b (N k) x y = N k
subs BT b (B z) x y = B z
subs BT b (LTE z w) x y = LTE (subs NT b z x y) (subs NT b w x y)
subs BT b (EQ z w) x y = EQ (subs NT b z x y) (subs NT b w x y)
subs a b (If z w s) x y =
  If (subs _ _ z x y) (subs _ _ w x y) (subs _ _ s x y)
subs a b (Var name a) (Var other b) y =
  if name == other
    then (case mapTyp b a y of
               Nothing => Var name a
               (Just x) => x)
    else Var name a
subs a b (Var name a) x y = Var name a
subs (FT domain codomain) b (Lam var value) x y =
  Lam (subs domain b var x y) (subs codomain b value x y)
subs a b (App c a f arg) x y =
  App c a (subs _ _ f x y) (subs c b arg x y)
subs NT b (Sum z w) x y = Sum (subs NT b z x y) (subs NT b w x y)
subs NT b (Pred z) x y = Pred (subs NT b z x y)
subs NT b (Prod z w) x y = Prod (subs NT b z x y) (subs NT b w x y)

-- A list of definitions of variables
public export
data Context : Type where
  Empty: Context
  Cons : (name: String) -> (type: Ty) -> (value: Exp type) -> (tail: Context) -> Context

varValue: Context -> (name: String) -> (ty: Ty) -> Maybe (Exp ty)
varValue Empty name ty = Nothing
varValue (Cons x type value tail) name ty =
  if (x==name)
    then (case mapTyp type ty value of
               Nothing => Nothing
               (Just x) => Just x)
    else Nothing

{-
Simplify an expression in context by one step if possible. The simplifications are:
  * if an expression is a variable defined in the context, it is replaced by its value
  * sums, products and predecessors of _literals_ are simplifed, e.g. `Sum (N 2) (N 3)` becomes `N 5`
  * a lambda function `x :-> y` applied to `z` simplifies to the result of subtituting `x` by `z` in `y`.
  * for any other composite term, we simplify the components.
-}
export
simplify : (ctx: Context) -> (a: Ty) -> (exp : Exp a) -> Exp a
simplify ctx NT (N k) = N k
simplify ctx BT (B x) = B x
simplify ctx BT (LTE (N x) (N y)) = B (x <= y)
simplify ctx BT (LTE x y) = LTE (simplify ctx NT x) (simplify ctx NT y)
simplify ctx BT (EQ (N x) (N y)) = B (x == y)
simplify ctx BT (EQ x y) = EQ (simplify ctx NT x) (simplify ctx NT y)
simplify ctx a (If (B True) y z) = y
simplify ctx a (If (B False) y z) = z
simplify ctx a (If x y z) = If (simplify ctx _ x) (simplify ctx _ y) (simplify ctx _ z)
simplify ctx a (Var name a) =
  (case varValue ctx name a of
        Nothing => Var name a
        (Just x) => x)
simplify ctx (FT domain codomain) (Lam var value) = Lam var value
simplify ctx a (App x a (Lam var value) arg) = subs _ _ value var arg
simplify ctx a (App x a f arg) = App x a (simplify ctx _ f) (simplify ctx _ arg)
simplify ctx NT (Sum (N x) (N y)) = N (x + y)
simplify ctx NT (Sum x y) = Sum (simplify ctx NT x) (simplify ctx NT y)
simplify ctx NT (Pred (N x)) = N (pred x)
simplify ctx NT (Pred x) = Pred (simplify ctx NT x)
simplify ctx NT (Prod (N x) (N y)) = N (x * y)
simplify ctx NT (Prod x y) = Prod (simplify ctx NT x) (simplify ctx NT y)

-- repeatedly simplify an expression giving a natural number till we get a literal (or loop forever)
reduce : Context -> Exp NT -> Nat
reduce ctx exp = case (simplify ctx NT exp) of
                  (N k) => k
                  x => reduce ctx x

-- a variable
n: Exp NT
n = Var "n" NT

-- a variable for the factorial function
fac : Exp (FT NT NT)
fac = Var "fac" (FT NT NT)

-- the expression `fac(n - 1)`
prev: Exp NT
prev = Prod (App NT NT fac (Pred n)) n

-- the expression `if n == 0 then 1 else fac(n-1)`
rhs : Exp NT
rhs = If (EQ n (N Z)) (N 1) prev

{- the context with definition:
  fac := n :-> (if (n == 0) then 1 else fac(n - 1)
-}
ctx: Context
ctx = Cons "fac" (FT NT NT) (Lam n rhs) Empty

-- function computing factorial
facFn: Nat -> Nat
facFn n = reduce ctx (App NT NT fac (N n))


module ProofColDivSeqBase
-- module Main -- ビルドするときはこっち > idris ProofColDivSeqBase.idr -o run

%default total
-- %language ElabReflection
%access export

-- mod2
public export
data Parity : Nat -> Type where
  Even : Parity (n + n)
  Odd  : Parity (S (n + n))
helpEven : (j : Nat) -> Parity (S j + S j) -> Parity (S (S (plus j j)))
helpEven j p = rewrite plusSuccRightSucc j j in p
helpOdd : (j : Nat) -> Parity (S (S (j + S j))) -> Parity (S (S (S (j + j))))
helpOdd j p = rewrite plusSuccRightSucc j j in p
parity : (n:Nat) -> Parity n
parity Z     = Even {n=Z}
parity (S Z) = Odd {n=Z}
parity (S (S k)) with (parity k)
  parity (S (S (j + j)))     | Even = helpEven j (Even {n = S j})
  parity (S (S (S (j + j)))) | Odd  = helpOdd j (Odd {n = S j})

-- mod3
public export
data Mod3 : Nat -> Type where
  ThreeZero : Mod3 (n + n + n)
  ThreeOne  : Mod3 (S (n + n + n))
  ThreeTwo  : Mod3 (S (S (n + n + n)))
helpThreeZero : (j:Nat) -> (plus (plus (S j) (S j)) (S j)) = S (S (S (plus (plus j j) j)))
helpThreeZero j = rewrite sym $ plusSuccRightSucc j j in
                  rewrite sym $ plusSuccRightSucc (plus j j) j in Refl
helpThreeOne : (j:Nat) -> S (plus (plus (S j) (S j)) (S j)) = S (S (S (S (plus (plus j j) j))))
helpThreeOne j = cong {f=S} $ helpThreeZero j
helpThreeTwo : (j:Nat) -> S (S (plus (plus (S j) (S j)) (S j))) = S (S (S (S (S (plus (plus j j) j)))))
helpThreeTwo j = cong {f=S} $ helpThreeOne j
mod3 : (n:Nat) -> Mod3 n
mod3 Z         = ThreeZero {n=Z}
mod3 (S Z)     = ThreeOne {n=Z}
mod3 (S (S Z)) = ThreeTwo {n=Z}
mod3 (S (S (S k))) with (mod3 k)
  mod3 (S (S (S (j + j + j))))         | ThreeZero =
    rewrite sym $ helpThreeZero j in ThreeZero {n=S j}
  mod3 (S (S (S (S (j + j + j)))))     | ThreeOne =
    rewrite sym $ helpThreeOne j in ThreeOne {n=S j}
  mod3 (S (S (S (S (S (j + j + j)))))) | ThreeTwo =
    rewrite sym $ helpThreeTwo j in ThreeTwo {n=S j}
-- ---------------------------------

-- allDivSeqの実装に必要な関数
-- ----- from libs/contrib/Data/CoList.idr -----
public export
codata CoList : Type -> Type where
  Nil : CoList a
  (::) : a -> CoList a -> CoList a

implementation Functor CoList where
  map f []      = []
  map f (x::xs) = f x :: map f xs

implementation Show a => Show (CoList a) where
  show xs = "[" ++ show' "" 20 xs ++ "]" where
    show' : String -> (n : Nat) -> (xs : CoList a) -> String
    show' acc Z _             = acc ++ "..."
    show' acc (S n) []        = acc
    show' acc (S n) [x]       = acc ++ show x
    show' acc (S n) (x :: xs) = show' (acc ++ (show x) ++ ", ") n xs

unfoldr : (a -> Maybe (b, a)) -> a -> CoList b
unfoldr f x =
  case f x of
    Just (y, new_x) => y :: (unfoldr f new_x)
    _               => []
-- ----- from libs/contrib/Data/CoList.idr -----

-- ----- from libs/base/Data/List/Quantifiers.idr -----
public export
data Any : (P : a -> Type) -> List a -> Type where
  Here  : {P : a -> Type} -> {xs : List a} -> P x -> Any P (x :: xs)
  There : {P : a -> Type} -> {xs : List a} -> Any P xs -> Any P (x :: xs)

anyNilAbsurd : {P : a -> Type} -> Any P Nil -> Void
anyNilAbsurd (Here _)  impossible
anyNilAbsurd (There _) impossible

implementation Uninhabited (Any p Nil) where
  uninhabited = anyNilAbsurd

public export
data All : (P : a -> Type) -> List a -> Type where
  NilA : {P : a -> Type} -> All P Nil
  Cons : {P : a -> Type} -> {xs : List a} -> P x -> All P xs -> All P (x :: xs)
-- ----- from libs/base/Data/List/Quantifiers.idr -----

dsp : List Integer -> Maybe (CoList Integer) -> Maybe (CoList Integer)
dsp xs                 Nothing          = Nothing
dsp xs                 (Just [])        = Nothing
dsp []                 (Just (y :: ys)) = Nothing
dsp (x :: [])          (Just (y :: ys)) = Nothing
dsp (x1 :: (x2 :: xs)) (Just (y :: ys)) = Just (x1 :: (x2+y) :: ys)

dsp2 : List Integer -> Maybe (CoList Integer) -> Maybe (CoList Integer)
dsp2 xs        Nothing          = Nothing
dsp2 xs        (Just [])        = Nothing
dsp2 []        (Just (y :: ys)) = Nothing
dsp2 (x :: xs) (Just (y :: ys)) = Just ((x+y) :: ys)

countEven : Nat -> Nat -> Nat -> (Nat, Nat)
countEven n Z      acc = (acc, n)
countEven n (S nn) acc =
  if (modNatNZ n 2 SIsNotZ) == 1
    then (acc, n)
    else countEven (divNatNZ n 2 SIsNotZ) nn (acc+1)

-- odd only!
divSeq : Nat -> CoList Integer
divSeq = (map toIntegerNat) .
  unfoldr (\b => if b==1 then Nothing
                         else Just (countEven (b*3+1) (b*3+1) 0) )
-- ---------------------------------

-- allDivSeqの実装
mutual
  allDivSeq : Nat -> Nat -> List (Maybe (CoList Integer))
  allDivSeq x Z = if (modNatNZ x 2 SIsNotZ) == 0 then [Nothing]
    else [Just (divSeq x)]
      ++ (if (modNatNZ (x+7) 4 SIsNotZ) == 0 && (modNatNZ (modNatNZ (x+7) 4 SIsNotZ) 2 SIsNotZ) == 1 then [[6,-4] `dsp` (Just (divSeq (divNatNZ ((x+7)*3) 4 SIsNotZ)))] else [])
      ++ (if (modNatNZ (x*6+3) 2 SIsNotZ) == 1 then [[1,-2] `dsp` (Just (divSeq (x*6+3)))] else [])
      ++ (if (modNatNZ (x*3+6) 2 SIsNotZ) == 1 then [[4,-4] `dsp` (Just (divSeq (x*3+6)))] else [])
      ++ (if (modNatNZ (x+1) 2 SIsNotZ) == 0 && (modNatNZ (modNatNZ (x+1) 2 SIsNotZ) 2 SIsNotZ) == 1 then [[3,-2] `dsp` (Just (divSeq (divNatNZ ((x+1)*3) 2 SIsNotZ)))] else [])
      ++ (if (modNatNZ (x*12+9) 2 SIsNotZ) == 1 then [[2,-4] `dsp` (Just (divSeq (x*12+9)))] else [])
      ++ (if (modNatNZ (x+3) 8 SIsNotZ) == 0 && (modNatNZ (modNatNZ (x+3) 8 SIsNotZ) 2 SIsNotZ) == 1 then [[5,-2] `dsp` (Just (divSeq (divNatNZ ((x+3)*3) 8 SIsNotZ)))] else [])
      ++ (if (modNatNZ (x `minus` 21) 64 SIsNotZ) == 0 && x > 21 && (modNatNZ (modNatNZ (x `minus` 21) 64 SIsNotZ) 2 SIsNotZ) == 1 then [[6] `dsp2` (Just (divSeq (divNatNZ (x `minus` 21) 64 SIsNotZ)))] else [])
  allDivSeq x (S lv) = allDivSeq x lv
                    ++ allDivSeqA x lv
                    ++ allDivSeqB x lv
                    ++ allDivSeqC x lv
                    ++ allDivSeqD x lv
                    ++ allDivSeqE x lv
                    ++ allDivSeqF x lv
                    ++ allDivSeqG x lv

  allDivSeqA : Nat -> Nat -> List (Maybe (CoList Integer))
  allDivSeqA x Z =
    if (modNatNZ (x+7) 4 SIsNotZ) == 0 && (modNatNZ (modNatNZ (x+7) 4 SIsNotZ) 2 SIsNotZ) == 1
      then [[6,-4] `dsp` (Just (divSeq (divNatNZ ((x+7)*3) 4 SIsNotZ)))]
      else []
  allDivSeqA x (S lv) =
    if (modNatNZ (x+7) 4 SIsNotZ) == 0
      then map ([6,-4] `dsp`) $ allDivSeq (divNatNZ ((x+7)*3) 4 SIsNotZ) (S lv)
      else []

  allDivSeqB : Nat -> Nat -> List (Maybe (CoList Integer))
  allDivSeqB x Z =
    if (modNatNZ (x*6+3) 2 SIsNotZ) == 1
      then [[1,-2] `dsp` (Just (divSeq (x*6+3)))]
      else []
  allDivSeqB x (S lv) =
      map ([1,-2] `dsp`) $ allDivSeq (x*6+3) (S lv)

  allDivSeqC : Nat -> Nat -> List (Maybe (CoList Integer))
  allDivSeqC x Z =
    if (modNatNZ (x*3+6) 2 SIsNotZ) == 1
      then [[4,-4] `dsp` (Just (divSeq (x*3+6)))]
      else []
  allDivSeqC x (S lv) =
      map ([4,-4] `dsp`) $ allDivSeq (x*3+6) (S lv)

  allDivSeqD : Nat -> Nat -> List (Maybe (CoList Integer))
  allDivSeqD x Z =
    if (modNatNZ (x+1) 2 SIsNotZ) == 0 && (modNatNZ (modNatNZ (x+1) 2 SIsNotZ) 2 SIsNotZ) == 1
      then [[3,-2] `dsp` (Just (divSeq (divNatNZ ((x+1)*3) 2 SIsNotZ)))]
      else []
  allDivSeqD x (S lv) =
    if (modNatNZ (x+1) 2 SIsNotZ) == 0
      then map ([3,-2] `dsp`) $ allDivSeq (divNatNZ ((x+1)*3) 2 SIsNotZ) (S lv)
      else []

  allDivSeqE : Nat -> Nat -> List (Maybe (CoList Integer))
  allDivSeqE x Z =
    if (modNatNZ (x*12+9) 2 SIsNotZ) == 1
      then [[2,-4] `dsp` (Just (divSeq (x*12+9)))]
      else []
  allDivSeqE x (S lv) =
      map ([2,-4] `dsp`) $ allDivSeq (x*12+9) (S lv)

  allDivSeqF : Nat -> Nat -> List (Maybe (CoList Integer))
  allDivSeqF x Z =
    if (modNatNZ (x+3) 8 SIsNotZ) == 0 && (modNatNZ (modNatNZ (x+3) 8 SIsNotZ) 2 SIsNotZ) == 1
      then [[5,-2] `dsp` (Just (divSeq (divNatNZ ((x+3)*3) 8 SIsNotZ)))]
      else []
  allDivSeqF x (S lv) =
    if (modNatNZ (x+3) 8 SIsNotZ) == 0
      then map ([5,-2] `dsp`) $ allDivSeq (divNatNZ ((x+3)*3) 8 SIsNotZ) (S lv)
      else []

  allDivSeqG : Nat -> Nat -> List (Maybe (CoList Integer))
  allDivSeqG x Z =
    if (modNatNZ (x `minus` 21) 64 SIsNotZ) == 0 && x > 21 && (modNatNZ (modNatNZ (x `minus` 21) 64 SIsNotZ) 2 SIsNotZ) == 1
      then [[6] `dsp2` (Just (divSeq (divNatNZ (x `minus` 21) 64 SIsNotZ)))]
      else []
  allDivSeqG x (S lv) =
    if (modNatNZ (x `minus` 21) 64 SIsNotZ) == 0 && x > 21
      then map ([6] `dsp2`) $ allDivSeq (divNatNZ (x `minus` 21) 64 SIsNotZ) (S lv)
      else []
-- ---------------------------------

-- その他関数
defini : (x, lv:Nat) -> allDivSeq x (S lv) = allDivSeq x lv
                                          ++ allDivSeqA x lv
                                          ++ allDivSeqB x lv
                                          ++ allDivSeqC x lv
                                          ++ allDivSeqD x lv
                                          ++ allDivSeqE x lv
                                          ++ allDivSeqF x lv
                                          ++ allDivSeqG x lv
defini x lv = Refl

definiA0 : (x : Nat) -> (allDivSeqA x Z) =
  (if (modNatNZ (x+7) 4 SIsNotZ) == 0 && (modNatNZ (modNatNZ (x+7) 4 SIsNotZ) 2 SIsNotZ) == 1
  then [[6,-4] `dsp` (Just (divSeq (divNatNZ ((x+7)*3) 4 SIsNotZ)))]
  else [])
definiA0 x = Refl
definiA : (x, lv:Nat) -> (allDivSeqA x (S lv)) =
  (if (modNatNZ (x+7) 4 SIsNotZ) == 0
  then map ([6,-4] `dsp`) $ allDivSeq (divNatNZ ((x+7)*3) 4 SIsNotZ) (S lv)
  else [])
definiA x lv = Refl

definiB0 : (x : Nat) -> (allDivSeqB x Z) =
  (if (modNatNZ (x*6+3) 2 SIsNotZ) == 1
  then [[1,-2] `dsp` (Just (divSeq (x*6+3)))]
  else [])
definiB0 x = Refl
definiB : (x, lv:Nat) -> (allDivSeqB x (S lv)) =
  map ([1,-2] `dsp`) $ allDivSeq (x*6+3) (S lv)
definiB x lv = Refl

definiC0 : (x : Nat) -> (allDivSeqC x Z) =
  (if (modNatNZ (x*3+6) 2 SIsNotZ) == 1
  then [[4,-4] `dsp` (Just (divSeq (x*3+6)))]
  else [])
definiC0 x = Refl
definiC : (x, lv:Nat) -> (allDivSeqC x (S lv)) =
  map ([4,-4] `dsp`) $ allDivSeq (x*3+6) (S lv)
definiC x lv = Refl

definiD0 : (x : Nat) -> (allDivSeqD x Z) =
  (if (modNatNZ (x+1) 2 SIsNotZ) == 0 && (modNatNZ (modNatNZ (x+1) 2 SIsNotZ) 2 SIsNotZ) == 1
  then [[3,-2] `dsp` (Just (divSeq (divNatNZ ((x+1)*3) 2 SIsNotZ)))]
  else [])
definiD0 x = Refl
definiD : (x, lv:Nat) -> (allDivSeqD x (S lv)) =
  (if (modNatNZ (x+1) 2 SIsNotZ) == 0
  then map ([3,-2] `dsp`) $ allDivSeq (divNatNZ ((x+1)*3) 2 SIsNotZ) (S lv)
  else [])
definiD x lv = Refl

definiE0 : (x : Nat) -> (allDivSeqE x Z) =
  (if (modNatNZ (x*12+9) 2 SIsNotZ) == 1
  then [[2,-4] `dsp` (Just (divSeq (x*12+9)))]
  else [])
definiE0 x = Refl
definiE : (x, lv:Nat) -> (allDivSeqE x (S lv)) =
  map ([2,-4] `dsp`) $ allDivSeq (x*12+9) (S lv)
definiE x lv = Refl

definiF0 : (x : Nat) -> (allDivSeqF x Z) =
  (if (modNatNZ (x+3) 8 SIsNotZ) == 0 && (modNatNZ (modNatNZ (x+3) 8 SIsNotZ) 2 SIsNotZ) == 1
  then [[5,-2] `dsp` (Just (divSeq (divNatNZ ((x+3)*3) 8 SIsNotZ)))]
  else [])
definiF0 x = Refl
definiF : (x, lv:Nat) -> (allDivSeqF x (S lv)) =
  (if (modNatNZ (x+3) 8 SIsNotZ) == 0
  then map ([5,-2] `dsp`) $ allDivSeq (divNatNZ ((x+3)*3) 8 SIsNotZ) (S lv)
  else [])
definiF x lv = Refl

definiG0 : (x : Nat) -> (allDivSeqG x Z) =
  (if (modNatNZ (x `minus` 21) 64 SIsNotZ) == 0 && x > 21 && (modNatNZ (modNatNZ (x `minus` 21) 64 SIsNotZ) 2 SIsNotZ) == 1
  then [[6] `dsp2` (Just (divSeq (divNatNZ (x `minus` 21) 64 SIsNotZ)))]
  else [])
definiG0 x = Refl
definiG : (x, lv:Nat) -> (allDivSeqG x (S lv)) =
  (if (modNatNZ (x `minus` 21) 64 SIsNotZ) == 0 && x > 21
  then map ([6] `dsp2`) $ allDivSeq (divNatNZ (x `minus` 21) 64 SIsNotZ) (S lv)
  else [])
definiG x lv = Refl

-- myAny : (a->Bool) -> List a -> Bool
-- myAny pp [] = False
-- myAny pp (x :: xs) = (pp x) || myAny pp xs

limitedNStep : Maybe (CoList Integer) -> Nat -> Bool
limitedNStep Nothing          _     = True
limitedNStep (Just [])        _     = True
limitedNStep (Just (_ :: _))  Z     = False
limitedNStep (Just (_ :: xs)) (S n) = limitedNStep (Just xs) n

public export
data Limited : Maybe (CoList Integer) -> Type where
  IsLimited : (n : Nat ** limitedNStep xs n = True) -> Limited xs

P : Nat -> Nat -> Type
P n lv = Not $ All Limited $ allDivSeq (n+n+n) lv

definiP : (n, lv : Nat)
  -> P n lv = Not $ All Limited $ allDivSeq (n+n+n) lv
definiP n lv = Refl
-- ---------------------------------

-- allDivSeq 0 2が有限項である事を示すため、mainを使う（ビルドして）
main : IO ()
main = traverse_ (putStrLn . show) $ allDivSeq 0 2


module Date

import Coda.Range

%access public export
%default total

{-
  ISO 8601 Date Package

  Date Representation inclues:

    Year - Month - Day

  Show interface includes zero-padding of up to 3 zeroes for Year, and 1 zero
  for month and day.

-}

{-
  Type Definitions
-}

data Year : Type where
  MkYear : (year : Integer) -> Year

%name Year y,y1,y2,y3

isLeap : Year -> Bool
isLeap (MkYear year) = (modNatNZ (toNat year) 4 SIsNotZ) == 0

data Month : Type where
  January   : Month
  February  : Month
  March     : Month
  April     : Month
  May       : Month
  June      : Month
  July      : Month
  August    : Month
  September : Month
  October   : Month
  November  : Month
  December  : Month

%name Month m,m1,m2,m3

monthOrder : Month -> Nat
monthOrder January   = 1
monthOrder February  = 2
monthOrder March     = 3
monthOrder April     = 4
monthOrder May       = 5
monthOrder June      = 6
monthOrder July      = 7
monthOrder August    = 8
monthOrder September = 9
monthOrder October   = 10
monthOrder November  = 11
monthOrder December  = 12

monthDays : Year -> Month -> Nat
monthDays _    January   = 30
monthDays year February  = if isLeap year then 29 else 28
monthDays _    March     = 30
monthDays _    April     = 31
monthDays _    May       = 30
monthDays _    June      = 31
monthDays _    July      = 30
monthDays _    August    = 31
monthDays _    September = 30
monthDays _    October   = 31
monthDays _    November  = 30
monthDays _    December  = 31

previousMonth : Month -> Month
previousMonth January   = December
previousMonth February  = January
previousMonth March     = February
previousMonth April     = March
previousMonth May       = April
previousMonth June      = May
previousMonth July      = June
previousMonth August    = July
previousMonth September = August
previousMonth October   = September
previousMonth November  = October
previousMonth December  = November

data Day : Type where
  MkDay : (day : Nat) -> Day

%name Day d,d1,d2,d3

inDayRange : Nat -> Day -> Type
inDayRange n (MkDay day) = inRange (MkRange Z (S n)) day

validDate : Year -> Month -> Day -> Type
validDate year month = inDayRange (monthDays year month)

data Date : Type where
  MkDate : (year : Year) ->
           (month : Month) ->
           (day : Day) ->
           { auto p : (validDate year month day) } -> Date

%name Date d,d1,d2,d3

{-
  Standard Interface Implementations
-}

Eq Year where
  (==) (MkYear y) (MkYear y') = y == y'

Eq Month where
  (==) x y  = monthOrder x == monthOrder y

Eq Day where
  (==) (MkDay y) (MkDay y') = y == y'

Eq Date where
  (==) (MkDate y m d) (MkDate y' m' d') = d == d' && m == m' && y == y'

Ord Year where
  compare (MkYear y) (MkYear y') = compare y y'

Ord Month where
  compare x y = compare (monthOrder x) (monthOrder y)

Ord Day where
  compare (MkDay d) (MkDay d') = compare d d'

Ord Date where
  compare (MkDate y m d) (MkDate y' m' d') =
    case compare y y' of
         EQ => case compare m m' of
                    EQ => compare d d'
                    result => result
         result => result

Show Year where
  show (MkYear year) =
    let s = show year
    in case length s of
            Z => "0000"
            (S Z) => "000" ++ s
            (S (S Z)) => "00" ++ s
            (S (S (S Z))) => "0" ++ s
            _ => s

Show Month where
  show x =
    let s = show $ monthOrder x
    in case length s of
            (S Z) => "0" ++ s
            _ => s

Show Day where
  show (MkDay day) =
    let s = show day
    in case length s of
            (S Z) => "0" ++ s
            _ => s

Show Date where
  show (MkDate y m d) = show y ++ "-" ++ show m ++ "-" ++ show d


module Linear.Epsilon

public export
interface Num a => Epsilon a where
  ||| Determine if a quantity is near zero.
  nearZero : a -> Bool

public export
implementation Epsilon Double where
  nearZero a = abs a <= (10 `pow` -12)