module Hands
import Data.Vect

import InsertionSort
import Card
import ElemsAreSame
import Sorted
import SlideWise

public export HAND_SIZE : Nat
HAND_SIZE = 5

--=======================================================================================================
--=======================================================================================================
--Utility proof data structures
--=======================================================================================================
--=======================================================================================================
data ForAll : Vect n elem -> (elem -> Type) -> Type where
  ForVect : prf x -> ForAll xs prf -> ForAll (x::r) prf
  End : ForAll [] pred

data AllSame : Vect n elem -> (elem -> elem -> Type) -> Type where
  EmptyIsSame: AllSame [] prf
  SingleIsSame: AllSame [x] prf
  Same: prf x y -> AllSame (y::ys) prf -> AllSame (x::y::ys) prf

data SameValue: Card -> Card -> Type where
  ValueMatch: SameValue (MkCard v _) (MkCard v _)

data SameSuit: Card -> Card -> Type where
  SuitMatch: SameSuit (MkCard _ s) (MkCard _ s)

--=======================================================================================================
--=======================================================================================================
--Hand Proof data structures
--=======================================================================================================
--=======================================================================================================
data PairH: Vect 2 Card -> Type where
  MkPair: PairH [(MkCard v _), (MkCard v _)]

data TwoPair: Vect HAND_SIZE Card -> Type where
  MkTwoPair: Sorted hand -> (firstpair: SlideWise2 hand PairH) -> (secondPair:SlideWise2 (getRest2 hand firstpair) PairH) -> TwoPair hand

data ThreeOfAKind : Vect 3 Card -> Type where
  MkThree: AllSame x SameValue -> ThreeOfAKind x

data Straight: Vect HAND_SIZE Card -> Type where
  MkStraight: Sorted x -> Consecutive x -> Straight x

data Flush: Vect HAND_SIZE Card -> Type where
  MkFlush: AllSame x SameSuit -> Flush x

data FullHouse: (hand:Vect HAND_SIZE Card) -> Type where
  MkFullHouse: Sorted hand -> (three: SlideWise3 hand ThreeOfAKind) -> (pair: PairH (getRest3 hand three)) -> FullHouse hand

data FourOfAKind : Vect 4 Card -> Type where
  MkFour: AllSame x SameValue -> FourOfAKind x

data StraightFlush: Vect HAND_SIZE Card -> Type where
  MkStraightFlush: Straight x -> Flush x -> StraightFlush x

--=======================================================================================================
--=======================================================================================================
--Hand
--=======================================================================================================
--=======================================================================================================
export data Hand: Vect HAND_SIZE Card -> Type where
  StraightFlushHand:
    StraightFlush x -> Hand x
  FourOfAKindHand:
    {auto p:Sorted y} -> SlideWise4 y FourOfAKind -> Hand y
  FullHouseHand:
    FullHouse y -> Hand y
  FlushHand:
    Flush x -> Hand x
  StraightHand:
    Straight x -> Hand x
  ThreeOfAKindHand:
    {auto p:Sorted y} -> SlideWise3 y ThreeOfAKind -> Hand y
  TwoPairHand:
    {auto p:Sorted y} -> TwoPair y -> Hand y
  PairHand:
    {auto p:Sorted y} -> SlideWise2 y PairH -> Hand y
  HighCardHand:
    {auto p:Sorted kickers} -> (kickers: Vect HAND_SIZE Card) -> Hand kickers

--=======================================================================================================
--=======================================================================================================
-- Utility proofs
--=======================================================================================================
--=======================================================================================================
--=======================================================================================================
-- hasSameSuit
--=======================================================================================================
notSameSuit : (contra : (s1 = s2) -> Void) -> SameSuit (MkCard value s1) (MkCard value1 s2) -> Void
notSameSuit contra SuitMatch = contra Refl

hasSameSuit: (c1: Card) -> (c2: Card) -> Dec (SameSuit c1 c2)
hasSameSuit (MkCard _ s1) (MkCard _ s2) = case decEq s1 s2 of
                                               (Yes prf) => Yes (rewrite prf in SuitMatch)
                                               (No contra) => No (notSameSuit contra)

--=======================================================================================================
-- hasSameValue
--=======================================================================================================
notSameValue : (contra : (v1 = v2) -> Void) -> SameValue (MkCard v1 suit) (MkCard v2 suit1) -> Void
notSameValue contra ValueMatch = contra Refl

hasSameValue: (c1: Card) -> (c2: Card) -> Dec (SameValue c1 c2)
hasSameValue (MkCard v1 _) (MkCard v2 _) = case decEq v1 v2 of
                                                (Yes prf) => Yes (rewrite prf in ValueMatch)
                                                (No contra) => No (notSameValue contra)
--=======================================================================================================
-- allSameSuit
--=======================================================================================================
restNotSameSuit : (contra : AllSame (x2 :: xs) SameSuit -> Void) -> AllSame (x1 :: (x2 :: xs)) SameSuit -> Void
restNotSameSuit contra (Same x y) = contra y

singleNotSameSuit : (contra : SameSuit x1 x2 -> Void) -> AllSame (x1 :: (x2 :: xs)) SameSuit -> Void
singleNotSameSuit contra (Same x y) = contra x

allSameSuit: (x: Vect n Card) -> Dec (AllSame x SameSuit)
allSameSuit [] = Yes EmptyIsSame
allSameSuit [x] = Yes SingleIsSame
allSameSuit (x1 :: x2 :: xs) = case allSameSuit (x2 :: xs) of
                                    (Yes prf_rest) => case hasSameSuit x1 x2 of
                                                               (Yes prf_single) => Yes (Same prf_single prf_rest)
                                                               (No contra) => No (singleNotSameSuit contra)
                                    (No contra) => No (restNotSameSuit contra)

--=======================================================================================================
-- isNoOfKind
--=======================================================================================================
restNotSame: (contra : AllSame (x2 :: xs) SameValue -> Void) -> AllSame (x1 :: (x2 :: xs)) SameValue -> Void
restNotSame contra (Same x y) = contra y

singleNotSame : (contra : SameValue x1 x2 -> Void) -> AllSame (x1 :: (x2 :: xs)) SameValue -> Void
singleNotSame contra (Same x y) = contra x

isNoOfKind: (x: Vect n Card) -> Dec (AllSame x SameValue)
isNoOfKind [] = Yes EmptyIsSame
isNoOfKind [x] = Yes SingleIsSame
isNoOfKind (x1 :: x2 :: xs) = case isNoOfKind (x2 :: xs) of
                           (Yes prf_rest) => (case hasSameValue x1 x2 of
                                              (Yes prf_single) => Yes (Same prf_single prf_rest)
                                              (No contra) => No (singleNotSame contra))
                           (No contra) => No (restNotSame contra)

--=======================================================================================================
--=======================================================================================================
--Hand Proofs
--=======================================================================================================
--=======================================================================================================
--=======================================================================================================
-- Pair
--=======================================================================================================
isNotPair : (contra : (v1 = v2) -> Void) -> PairH [(MkCard v1 suit), (MkCard v2 suit1)] -> Void
isNotPair contra MkPair = contra Refl

isPair: (p: Vect 2 Card) -> Dec (PairH p)
isPair [(MkCard v1 _), (MkCard v2 _)] = case decEq v1 v2 of
                                          (Yes prf) => Yes (rewrite prf in MkPair)
                                          (No contra) => No (isNotPair contra)

isPairHand: (hand: Vect HAND_SIZE Card) -> {auto sort_prf: Sorted hand }-> Dec (SlideWise2 hand PairH)
isPairHand hand {sort_prf} = isSlideWise2 hand isPair
--=======================================================================================================
-- Two Pair
--=======================================================================================================
pairInRest: {hand: Vect HAND_SIZE Card} -> (firstPair: SlideWise2 hand PairH) -> Dec (SlideWise2 (getRest2 hand firstPair) PairH)
pairInRest (HeadMatches2 searched match rest x) = isSlideWise2 (getRest2 (match ++ rest) (HeadMatches2 searched match rest x)) isPair
pairInRest (RestMatches2 x rest y) = isSlideWise2 (getRest2 (x :: rest) (RestMatches2 x rest y)) isPair

||| TODO return Dec instead
isTwoPairHand: (hand: Vect HAND_SIZE Card) -> {auto sort_prf: Sorted hand} ->  Maybe (TwoPair hand)
isTwoPairHand hand {sort_prf} = case isPairHand hand of
                                   (Yes first_prf) => (case pairInRest first_prf of
                                                      (Yes snd_prf) => Just (MkTwoPair sort_prf first_prf snd_prf)
                                                      (No contra) => Nothing)
                                   (No contra) => Nothing

--=======================================================================================================
-- Three of a Kind
--=======================================================================================================
notThreeOfAKind : (contra : AllSame x SameValue -> Void) -> ThreeOfAKind x -> Void
notThreeOfAKind contra (MkThree x) = contra x

isThreeOfAKind: (x: Vect 3 Card) -> Dec (ThreeOfAKind x)
isThreeOfAKind x = case isNoOfKind x of
                        (Yes prf) => Yes (MkThree prf)
                        (No contra) => No (notThreeOfAKind contra)

isThreeOfAKindHand: (hand: Vect 5 Card) -> {auto sort_prf: Sorted hand} -> Dec (SlideWise3 hand ThreeOfAKind)
isThreeOfAKindHand hand = isSlideWise3 hand isThreeOfAKind
--=======================================================================================================
-- Straight
--=======================================================================================================
notConsecSoNotStraight : (contra : Consecutive x -> Void) -> Straight x -> Void
notConsecSoNotStraight contra (MkStraight x y) = contra y

isStraight: (x: Vect HAND_SIZE Card) -> {auto sort_prf:Sorted x} -> Dec (Straight x)
isStraight {sort_prf} x = case isConsecutive x of
                         (Yes prf) => Yes (MkStraight sort_prf prf)
                         (No contra) => No (notConsecSoNotStraight contra)

--=======================================================================================================
-- Flush
--=======================================================================================================
notFlush : (contra : AllSame x SameSuit -> Void) -> Flush x -> Void
notFlush contra (MkFlush (Same z w)) = contra (Same z w)

isFlush: (x: Vect HAND_SIZE Card) -> Dec (Flush x)
isFlush x = case allSameSuit x of
                 (Yes prf) => Yes (MkFlush prf)
                 (No contra) => No (notFlush contra)
--=======================================================================================================
-- Full House
--=======================================================================================================
isFullHouse: (hand: Vect HAND_SIZE Card) -> (sort_prf: Sorted hand) -> Maybe (FullHouse hand)
isFullHouse hand sort_prf = case isThreeOfAKindHand hand of
                                 (No contra) => Nothing
                                 (Yes three_prf) => (case isPair (getRest3 hand three_prf) of
                                                          (Yes pair_prf) => Just (MkFullHouse sort_prf three_prf pair_prf)
                                                          (No contra) => Nothing)

--=======================================================================================================
-- Four of a Kind
--=======================================================================================================
notFourOfAKind : (contra : AllSame x SameValue -> Void) -> FourOfAKind x -> Void
notFourOfAKind contra (MkFour x) = contra x

isFourOfAKind: (x: Vect 4 Card) -> Dec (FourOfAKind x)
isFourOfAKind x = case isNoOfKind x of
                       (Yes prf) => Yes (MkFour prf)
                       (No contra) => No (notFourOfAKind contra)

isFourOfAKindHand: (hand: Vect 5 Card) -> Sorted hand -> Dec (SlideWise4 hand FourOfAKind)
isFourOfAKindHand hand sort_prf = isSlideWise4 hand isFourOfAKind

--=======================================================================================================
-- Straight Flush
--=======================================================================================================
notStraightSoNotSF : (contra : Straight x -> Void) -> StraightFlush x -> Void
notStraightSoNotSF contra (MkStraightFlush straight flush) = contra straight

notFlushSoNotSF : (contra : Flush x -> Void) -> StraightFlush x -> Void
notFlushSoNotSF contra (MkStraightFlush straight flush) = contra flush

isStraightFlush: (x: Vect HAND_SIZE Card) -> {auto sort_prf:Sorted x} -> Dec (StraightFlush x)
isStraightFlush x = case isStraight x of
                         (Yes straight_prf) => (case isFlush x of
                                            (Yes flush_prf) => Yes (MkStraightFlush straight_prf flush_prf)
                                            (No contra) => No (notFlushSoNotSF contra))
                         (No contra) => No (notStraightSoNotSF contra)

--=======================================================================================================
--=======================================================================================================
-- Hand evaluator
--=======================================================================================================
--=======================================================================================================

evalRestHand : (hand: Vect HAND_SIZE Card) -> (sort_prf : Sorted hand) -> (contra_4 : SlideWise4 hand FourOfAKind -> Void) -> (contra_sf : StraightFlush hand -> Void) -> Hand hand
evalRestHand hand sort_prf contra_4 contra_sf = case isFlush hand of
                                                     (Yes prf) => FlushHand prf
                                                     (No contra_flush) => (case isStraight hand of
                                                                                (Yes prf) => StraightHand prf
                                                                                (No contra) => (case isThreeOfAKindHand hand of
                                                                                (Yes prf) => ThreeOfAKindHand prf
                                                                                (No contra) => (case isTwoPairHand  hand of
                                                                                (Just prf) => TwoPairHand prf
                                                                                Nothing => (case isPairHand hand of
                                                                                (Yes prf) => PairHand prf
                                                                                (No contra) => HighCardHand hand))))

export evalHand: (hand: Vect HAND_SIZE Card) -> Sorted hand -> Hand hand
evalHand hand sort_prf = case isStraightFlush hand of
                              (Yes prf) => StraightFlushHand prf
                              (No contra_sf) => (case isFourOfAKindHand hand sort_prf of
                                                Yes prf => FourOfAKindHand prf
                                                No contra_4 => (case isFullHouse hand sort_prf of
                                                                      Just prf => FullHouseHand prf
                                                                      Nothing => evalRestHand hand sort_prf contra_4 contra_sf))

compareStraightFlushes : (x : StraightFlush h1) -> (y : StraightFlush h2) -> Ordering
compareStraightFlushes {h1 = (x1 :: xs1)} {h2 = (x2:: xs2)} x y = compare (cardValue x1) (cardValue x2)

compareFourOfAKinds : (x : SlideWise4 h1 FourOfAKind) -> (y : SlideWise4 h2 FourOfAKind) -> Ordering
compareFourOfAKinds {h1} {h2} x y = let ((x1::xs), kicker1::[]) = getMatchAndRest4 h1 x
                                        ((y1::ys), kicker2::[]) = getMatchAndRest4 h2 y in
                                        (case compare (cardValue x1) (cardValue y1) of
                                              LT => LT
                                              EQ => compare (cardValue kicker1) (cardValue kicker2)
                                              GT => GT)

compareHighCards : (h1 : Vect n Card) -> (h2 : Vect n Card) -> Ordering
compareHighCards [] [] = EQ
compareHighCards (x :: xs) (y :: ys) = case compare (cardValue x) (cardValue y) of
                                            LT => LT
                                            EQ => compareHighCards xs ys
                                            GT => GT

compareFlushes : (x : Flush h1) -> (y : Flush h2) -> Ordering
compareFlushes {h1} {h2} x y = compareHighCards h1 h2

comparePairs : {h1, h2: Vect (S(S n)) Card} -> (x : SlideWise2 h1 PairH) -> (y : SlideWise2 h2 PairH) -> Ordering
comparePairs {h1} {h2} x y = let ((x1::xs), kickers1) = getMatchAndRest2 h1 x
                                 ((y1::ys), kickers2) = getMatchAndRest2 h2 y in
                                 (case compare (cardValue x1) (cardValue y1) of
                                        LT => LT
                                        EQ => compareHighCards kickers1 kickers2
                                        GT => GT)

getHighLowPair: Card -> Card -> (Card, Card)
getHighLowPair x y = case compare (cardValue x) (cardValue y) of
               LT => (y, x)
               gtOrEq => (x, y)

compareTwoPairs : {h1, h2: Vect HAND_SIZE Card} -> (x : TwoPair h1) -> (y : TwoPair h2) -> Ordering
compareTwoPairs {h1} {h2} (MkTwoPair x firstPair1 secondPair1)
                (MkTwoPair y firstPair2 secondPair2) = let (firstmatch1::f1) = getMatch2 h1 firstPair1
                                                           (secondmatch1::s1, kicker1::[]) = getMatchAndRest2 (getRest2 h1 firstPair1) secondPair1
                                                           (firstmatch2::f2) = getMatch2 h2 firstPair2
                                                           (secondmatch2::s2, kicker2::[]) = getMatchAndRest2 (getRest2 h2 firstPair2) secondPair2
                                                           (highestPair1, lowestPair1) = getHighLowPair firstmatch1 secondmatch1
                                                           (highestPair2, lowestPair2) = getHighLowPair firstmatch2 secondmatch2
                                                           in
                                                           (case compare (cardValue highestPair1) (cardValue highestPair2) of
                                                                 LT => LT
                                                                 GT => GT
                                                                 EQ => (case compare (cardValue lowestPair1) (cardValue lowestPair2) of
                                                                             LT => LT
                                                                             EQ => compare (cardValue kicker1) (cardValue kicker2)
                                                                             GT => GT))

compareThreeOfAKinds : {h1, h2: Vect (S(S(S n))) Card} -> (x : SlideWise3 h1 ThreeOfAKind) -> (y : SlideWise3 h2 ThreeOfAKind) -> Ordering
compareThreeOfAKinds {h1} {h2} x y = let ((x1::xs), kickers1) = getMatchAndRest3 h1 x
                                         ((y1::ys), kickers2) = getMatchAndRest3 h2 y in
                                          (case compare (cardValue x1) (cardValue y1) of
                                              LT => LT
                                              EQ => compareHighCards kickers1 kickers2
                                              GT => GT)

comparePairHs : (pair_prf1 : PairH h1) -> (pair_prf2 : PairH h2) -> Ordering
comparePairHs {h1} {h2} pair_prf1 pair_prf2 = compareHighCards h1 h2

compareFullHouseHands : (x : FullHouse h1) -> (y : FullHouse h2) -> Ordering
compareFullHouseHands {h1} (MkFullHouse x three_prf1 pair_prf1)
                      {h2} (MkFullHouse y three_prf2 pair_prf2) = let (threeCard1::_) = (getMatch3 h1 three_prf1)
                                                                      (threeCard2::_) = (getMatch3 h2 three_prf2) in
                                                                      (case compare (cardValue threeCard1) (cardValue threeCard2) of
                                                                            LT => LT
                                                                            EQ => comparePairHs pair_prf1 pair_prf2
                                                                            GT => GT)

compareStraights : {h1, h2: Vect HAND_SIZE Card} -> (x : Straight h1) -> (y : Straight h2) -> Ordering
compareStraights {h1} {h2} x y = compareHighCards h1 h2

export compareHands: {h1, h2: Vect HAND_SIZE Card} -> (hand1: Hand h1) -> (hand2: Hand h2) -> Ordering
compareHands (StraightFlushHand x) (StraightFlushHand y) = compareStraightFlushes x y
compareHands (StraightFlushHand x) hand2 = GT
compareHands (FourOfAKindHand x) (StraightFlushHand y) = LT
compareHands (FourOfAKindHand x) (FourOfAKindHand y) = compareFourOfAKinds x y
compareHands (FourOfAKindHand x) hand2 = GT
compareHands (FullHouseHand x) (StraightFlushHand y) = LT
compareHands (FullHouseHand x) (FourOfAKindHand y) = LT
compareHands (FullHouseHand x) (FullHouseHand y) = compareFullHouseHands x y
compareHands (FullHouseHand x) hand2 = GT
compareHands (FlushHand x) (StraightFlushHand y) = LT
compareHands (FlushHand x) (FourOfAKindHand y) = LT
compareHands (FlushHand x) (FullHouseHand y) = LT
compareHands (FlushHand x) (FlushHand y) = compareFlushes x y
compareHands (FlushHand x) hand2 = GT
compareHands (StraightHand x) (StraightFlushHand y) = LT
compareHands (StraightHand x) (FourOfAKindHand y) = LT
compareHands (StraightHand x) (FullHouseHand y) = LT
compareHands (StraightHand x) (FlushHand y) = LT
compareHands (StraightHand x) (StraightHand y) = compareStraights x y
compareHands (StraightHand x) hand2 = GT
compareHands (ThreeOfAKindHand x) (StraightFlushHand y) = LT
compareHands (ThreeOfAKindHand x) (FourOfAKindHand y) = LT
compareHands (ThreeOfAKindHand x) (FullHouseHand y) = LT
compareHands (ThreeOfAKindHand x) (FlushHand y) = LT
compareHands (ThreeOfAKindHand x) (StraightHand y) = LT
compareHands (ThreeOfAKindHand x) (ThreeOfAKindHand y) = compareThreeOfAKinds x y
compareHands (ThreeOfAKindHand x) hand2 = GT
compareHands (TwoPairHand x) (HighCardHand h2) = GT
compareHands (TwoPairHand x) (PairHand y) = GT
compareHands (TwoPairHand x) (TwoPairHand y) = compareTwoPairs x y
compareHands (TwoPairHand x) hand2 = LT
compareHands (PairHand x) (HighCardHand h2) = GT
compareHands (PairHand x) (PairHand y) = comparePairs x y
compareHands (PairHand x) hand2 = LT
compareHands (HighCardHand h1) (HighCardHand h2) = compareHighCards h1 h2
compareHands (HighCardHand h1) hand2 = LT

showHighCard : (h : Vect HAND_SIZE Card) -> String
showHighCard (x :: xs) = "High Card: " ++ (show (cardValue x))

showPair :{h: Vect HAND_SIZE Card} -> (x : SlideWise2 h PairH) -> String
showPair {h} x = let (m::ms, r::rs) = getMatchAndRest2 h x in
                "Pair: " ++ (show (cardValue m)) ++ "s with a " ++ (show (cardValue r)) ++ " kicker"

showTwoPair : (x : TwoPair h)-> String
showTwoPair {h} (MkTwoPair x firstPair secondPair) = let (m1::ms1) = getMatch2 h firstPair
                                                         (m2::ms2, [kicker]) = getMatchAndRest2 (getRest2 h firstPair) secondPair in
                                                         "Two Pair: " ++ (show (cardValue m1)) ++ "s and " ++ (show (cardValue m2)) ++ "s with a " ++ (show (cardValue kicker)) ++ " kicker"

showThreeOfAKind : (x : SlideWise3 h ThreeOfAKind) -> String
showThreeOfAKind {h} x = let (m::ms, r::rs) = getMatchAndRest3 h x in
                "Three of a kind: " ++ (show (cardValue m)) ++ "s with a " ++ (show (cardValue r)) ++ " kicker"

showStraight : (x : Straight h) -> String
showStraight {h = (z :: xs)} (MkStraight x y) = "Straight: " ++ (show (cardValue z)) ++ " high"

showFlush : (x : Flush h) -> String
showFlush {h = (y :: xs)} x = "Flush: " ++ (show (cardValue y)) ++ " high"

showFullHouse : (x : FullHouse h) -> String
showFullHouse {h} (MkFullHouse x three pair) = let (m1::m1s) = getMatch3 h three
                                                   (m2::m2s) = (getRest3 h three) in
                                                   "Full house: " ++ (show (cardValue m1)) ++ "s over " ++ (show (cardValue m2)) ++ "s"

showFourOfAKind : (x : SlideWise4 h FourOfAKind) -> String
showFourOfAKind {h} x = let (m::ms, [kicker]) = getMatchAndRest4 h x in
                "Four of a kind: " ++ (show (cardValue m)) ++ "s with a " ++ (show (cardValue kicker)) ++ " kicker"

showStraightFlush : (x : StraightFlush h) -> String
showStraightFlush {h = (y :: xs)} x = "Straight flush: " ++ (show (cardValue y)) ++ " high"

export Show (Hand h) where
  show (StraightFlushHand x) = showStraightFlush x
  show (FourOfAKindHand x) = showFourOfAKind x
  show (FullHouseHand x) = showFullHouse x
  show (FlushHand x) = showFlush x
  show (StraightHand x) = showStraight x
  show (ThreeOfAKindHand x) = showThreeOfAKind x
  show (TwoPairHand x) = showTwoPair x
  show (PairHand x) = showPair x
  show (HighCardHand h) = showHighCard h


module Issue833

import Data.Fin

%default total

data Singleton : Nat -> Type where
  Sing : {n : Nat} -> Singleton n

f : (n : Singleton Z) -> n === Sing
f = \ Sing => Refl

g : (k : Fin 1) -> k === FZ
g = \ FZ => Refl

sym : {t, u : a} -> t === u -> u === t
sym = \Refl => Refl


> module Pairs.Operations

> import Sigma.Sigma

> %default total
> %access public export
> %auto_implicits on

> -- %hide getWitness
> -- %hide getProof

> {-

> namespace Exists
>   getWitness : {P : a -> Type} -> Exists {a} P -> a
>   getWitness (Evidence x pf) = x
>   getProof : {P : a -> Type} -> (x : Exists {a} P) -> P (getWitness x)
>   getProof (Evidence x pf) = pf

> namespace Subset
>   getWitness : {P : a -> Type} -> Subset a P -> a
>   getWitness (Element x pf) = x
>   getProof : {P : a -> Type} -> (x : Subset a P) -> P (getWitness x)
>   getProof (Element x pf) = pf

> ---}

> namespace Sigma
>   getWitness : {P : a -> Type} -> Sigma a P -> a
>   getWitness (MkSigma x pf) = x
>   getProof : {P : a -> Type} -> (x : Sigma a P) -> P (getWitness x)
>   getProof (MkSigma x pf) = pf


import Data.Vect

append_nil : Vect m elem -> Vect (plus m 0) elem
append_nil xs = rewrite plusZeroRightNeutral m in xs

append_xs : Vect (S (m + len)) elem -> Vect (m + (S len)) elem
append_xs xs = rewrite sym (plusSuccRightSucc m len) in xs

-- by "carelessly" changing `n + m` to `m + n` we need use a few rewrites
-- to prove to idris that the definition is valid
append : Vect n elem -> Vect m elem -> Vect (m + n) elem
append [] ys = append_nil ys
append (x :: xs) ys = append_xs (x :: append xs ys)


module Cursor

import Data.Fin

%default total

public export
data Cursor : Nat -> Type where
  MkCursor : Nat -> Fin n -> Cursor n

export
right : Cursor n -> Cursor n
right (MkCursor x y) = MkCursor (S x) y

export
left : Cursor n -> Cursor n
left (MkCursor (S x) y) = MkCursor x y
left (MkCursor Z y) = MkCursor Z y

dec : Fin n -> Fin n
dec FZ = FZ
dec (FS k) = weaken k

export
up : Cursor n -> Cursor n
up (MkCursor x y) = MkCursor x (dec y)

export
down : Cursor n -> Cursor (S n)
down (MkCursor x y) = MkCursor x (shift 1 y)

export
downInBounds : Cursor n -> Cursor n
downInBounds originalCursor@(MkCursor x y) =
  case strengthen $ shift 1 y of
    Left _ => originalCursor
    Right newY => MkCursor x newY

--todo: is it possible to use something like strengthenN and shift?
export
downWithnInBounds : Nat -> Cursor n -> Cursor n
downWithnInBounds d originalCursor@(MkCursor x y) {n} =
  case natToFin ((finToNat y) + d) n of
    Nothing => originalCursor
    Just newY => MkCursor x newY

export
lineStart : Cursor n -> Cursor n
lineStart (MkCursor _ y) = MkCursor Z y


module Main

import Data.Vect

data Box = X | O | Empty

isEmpty : Box -> Bool
isEmpty Empty = True
isEmpty _ = False

Board : (size : Nat) -> Type
Board size = Vect size (Vect size Box)

newBoard : (size : Nat) -> Board size
newBoard size = replicate size (replicate size Empty)

markColumn : Box -> Vect x Box -> Fin x -> Maybe (Vect x Box)
markColumn mark (x :: xs) FZ = case x of
                                    Empty => Just (mark :: xs)
                                    _ => Nothing
markColumn mark (x :: xs) (FS y) = case markColumn mark xs y of
                                        Nothing => Nothing
                                        Just rest => Just (x :: rest)

markSquare : Vect x (Vect y Box) -> Box -> Fin x -> Fin y -> Maybe (Vect x (Vect y Box))
markSquare (x :: xs) mark FZ j = case markColumn mark x j of
                                      Nothing => Nothing
                                      Just new_x => Just (new_x :: xs)
markSquare (x :: xs) mark (FS i) j = case markSquare xs mark i j of
                                          Nothing => Nothing
                                          Just rest => Just (x :: rest)

checkVect : Vect x Box -> Maybe Box
checkVect [] = Just Empty
checkVect (x :: xs) = let rest = checkVect xs in
                          match x rest where
                           match : Box -> Maybe Box -> Maybe Box
                           match x Nothing = Nothing
                           match X (Just X) = Just X
                           match X (Just O) = Nothing
                           match X (Just Empty) = Just X
                           match O (Just X) = Nothing
                           match O (Just O) = Just O
                           match O (Just Empty) = Just O
                           match Empty (Just y) = Nothing

checkRows : Vect x (Vect y Box) -> Maybe Box
checkRows [] = Nothing
checkRows (x :: xs) = case checkVect x of
                           Just X => Just X
                           Just Y => Just Y
                           _ => checkRows xs

checkCols : Vect x (Vect y Box) -> Maybe Box
checkCols board = checkRows (transpose board)

checkDiags : Board size -> Maybe Box
checkDiags {size} board = case checkVect (diag board) of
                              Just a => Just a
                              Nothing => case checkVect (diag (reverse board)) of
                                              Just a => Just a
                                              Nothing => Nothing

findLegalMoves : Vect x (Vect y Box) -> Nat -> List (Nat, Nat)
findLegalMoves [] i = []
findLegalMoves (x :: xs) i = let hits = the (List Nat) (findIndices isEmpty (toList x)) in
                                 (zip (replicate (length hits) i) hits) ++ (findLegalMoves xs (i+1))

checkDraw : Board size -> Bool
checkDraw board  = (length (findLegalMoves board 0)) == 0

checkVictory : Board size -> Maybe Box
checkVictory b = case checkRows b of
                      Just X => Just X
                      Just O => Just O
                      Nothing => case checkCols b of
                                      Just X => Just X
                                      Just O => Just O
                                      Nothing => case checkDiags b of
                                                      Just X => Just X
                                                      Just O => Just O
                                                      Nothing => case checkDraw b of
                                                                      True => Just Empty
                                                                      False => Nothing
readNumber : IO (Maybe Nat)
readNumber = do input <- getLine
                if all isDigit (unpack input)
                   then pure (Just (cast input))
                   else pure Nothing

getMove : Board size -> IO (Fin size, Fin size)
getMove board {size} = do putStr "Enter row: "
                          Just row <- readNumber | Nothing => getMove board
                          let fRow = natToFin row size
                          putStr "Enter col: "
                          Just col <- readNumber | Nothing => getMove board
                          let fCol = natToFin col size
                          case finalizeMove fRow fCol of
                               Nothing => getMove board
                               Just move => pure move
            where
              finalizeMove : Maybe (Fin b) -> Maybe (Fin b) -> Maybe (Fin b, Fin b)
              finalizeMove Nothing y = Nothing
              finalizeMove (Just x) Nothing = Nothing
              finalizeMove (Just x) (Just y) = Just (x, y)

formattedRow : Vect n String -> String
formattedRow [] = ""
formattedRow (x :: xs) = x ++ (formattedRow xs)

stringify : Box -> String
stringify X = "X"
stringify O = "O"
stringify Empty = " "

showBoard : Vect n (Vect m Box) -> String
showBoard [] = ""
showBoard (x :: xs) {m} = (formattedRow (intersperse "|" (map stringify x))) ++ "\n" ++
                        rest xs where
                        rest : Vect n' (Vect m Box) -> String
                        rest [] = showBoard xs
                        rest xs = (formattedRow (replicate (2 * m) "-")) ++ "\n" ++ (showBoard xs)

flipPlayer : Box -> Box
flipPlayer X = O
flipPlayer O = X
flipPlayer Empty = Empty

runGame : Board size -> Box -> IO ()
runGame [] player  = putStrLn "weird board!"
runGame board player = do putStrLn (showBoard board)
                          putStrLn ((stringify player) ++ "'s turn: ")
                          move <- getMove board
                          case markSquare board player (fst move) (snd move) of
                               Nothing => runGame board player
                               Just new_board => case checkVictory new_board of
                                                      Nothing => runGame new_board (flipPlayer player)
                                                      Just Empty => putStrLn "Draw"
                                                      Just b => putStrLn ((stringify b) ++ " wins!")

main : IO ()
main = do runGame (newBoard 3) X


module IndProp

import Logic

%access public export

%default total

data Reflect : (p : Type) -> Bool -> Type where
  ReflectT : p -> (b=True) -> Reflect p b
  ReflectF : (Not p) -> (b=False) -> Reflect p b

iff_reflect : (p ↔ (b=True)) -> Reflect p b
iff_reflect {b = False} (pb, _) = ReflectF (uninhabited . pb) Refl
iff_reflect {b = True} (_, bp) = ReflectT (bp Refl) Refl

reflect_iff : Reflect p b -> (p ↔ (b=True))
reflect_iff (ReflectT p b_true) = (\_ => b_true, \_ => p)
reflect_iff (ReflectF not_p b_false) =
  ( \p => void (not_p p)
  , \b_true => void . uninhabited $
      the (False = True) $ rewrite sym b_false in b_true)


> module Void.Properties

> import Data.Fin
> import Control.Isomorphism

> import Finite.Predicates
> import Sigma.Sigma

> %default total

> %access public export

> ||| Mapping |Void|s to |Fin|s
> toFin : Void -> Fin Z
> toFin = void
> %freeze toFin

> ||| Mapping |Fin Z|s to |Void|s
> fromFin : Fin Z -> Void
> fromFin k = absurd k
> %freeze fromFin

> ||| |toFin| is the left-inverse of |fromFin|
> toFinFromFinLemma : (k : Fin Z) -> toFin (fromFin k) = k
> toFinFromFinLemma k = absurd k
> %freeze toFinFromFinLemma

> ||| |fromFin| is the left-inverse of |toFin|
> fromFinToFinLemma : (e : Void) -> fromFin (toFin e) = e
> fromFinToFinLemma e = void e
> %freeze fromFinToFinLemma

> ||| Void is finite
> finiteVoid : Finite Void
> finiteVoid = MkSigma Z iso where
>   iso : Iso Void (Fin Z)
>   iso = MkIso toFin fromFin toFinFromFinLemma fromFinToFinLemma

> ||| Void is decidable
> decidableVoid : Dec Void
> decidableVoid = No void

> {-

> ---}


-- Exercises.idr
-- Solutions for exercises of chapter 2

module Exercises

import Data.Vect

-- length function
myLength : List a -> Nat
myLength [] = 0
myLength (x :: xs) = 1 + myLength xs

-- reverse function
myReverse : List a -> List a
myReverse [] = []
myReverse (x :: xs) = (myReverse xs) ++ [x]

-- myVectReverse : Vect n a -> Vect n a
-- myVectReverse [] = []
-- myVectReverse (x :: xs) = (?myVectReverse_rhs xs) ++ (the (Vect 1 _) [x])

-- map function
myMap : (a -> b) -> List a -> List b
myMap f [] = []
myMap f (x :: xs) = f x :: myMap f xs

myVectMap : (a -> b) -> Vect n a -> Vect n b
myVectMap f [] = []
myVectMap f (x :: xs) = f x :: myVectMap f xs


module GenericAdder

%default total

AdderType : (numargs : Nat) -> (elemType : Type) -> Type
AdderType Z ty = ty
AdderType (S k) ty = (next : ty) -> AdderType k ty

adder : Num elemType => (numargs : Nat) -> (acc : elemType) -> AdderType numargs elemType
adder Z acc = acc
adder (S k) acc = \next => adder k (acc + next)


module Part2.Sec9_2_hangman
import Data.Vect
import Part2.Sec9_1_elem

%default total

data WordState : (guesses_remaining : Nat) -> (letters : Nat) -> Type where
     MkWordState : (word : String) ->
                   (missing : Vect letters Char) ->
                   WordState guesses_remaining letters

data Finished : Type where
             Lost : (game : WordState 0 (S letters)) -> Finished
             Won  : (game : WordState (S guesses) 0) -> Finished

processGuess : (letter : Char) -> WordState (S guesses) (S letters) -> Either (WordState guesses (S letters)) (WordState (S guesses) letters)
processGuess letter (MkWordState word missing) = case isElem letter missing of
          Yes prf => Right (MkWordState word (removeElem_auto letter missing))
          No contra => Left (MkWordState word missing)

{- the rest is user interface code -}

data ValidInput : List Char -> Type where
     Letter : (c : Char) -> ValidInput [c]

invalidNil : ValidInput [] -> Void
invalidNil (Letter _) impossible

invalidTwo : ValidInput (x :: y :: xs) -> Void
invalidTwo (Letter _) impossible

isValidInput : (cs : List Char) -> Dec (ValidInput cs)
isValidInput [] = No invalidNil
isValidInput (x :: []) = Yes (Letter x)
isValidInput (x :: (y :: xs)) = No invalidTwo

isValidString : (s : String) -> Dec (ValidInput (unpack s))
isValidString s = isValidInput (unpack s)

covering
readGuess : IO (x ** ValidInput x)
readGuess = do putStr "Guess:"
               x <- getLine
               case isValidString (toUpper x) of
                  Yes prf => pure (_ ** prf)
                  No contra => do putStrLn "Invalid guess"
                                  readGuess

covering
game : WordState (S guesses) (S letters) -> IO Finished
game {guesses} {letters} st
             = do (_ ** Letter letter) <- readGuess
                  case processGuess letter st of
                    Left l => do putStrLn "Wrong!"
                                 case guesses of
                                      Z => pure (Lost l)
                                      S k => game l
                    Right r => do putStrLn "Right!"
                                  case letters of
                                       Z => pure (Won r)
                                       S k => game r

{- To execute in repl, idrs repl from src folder, :l this file and use :exec sec_9_2 -}
covering
sec_9_2 : IO ()
sec_9_2 = do result <- game {guesses=2} (MkWordState "Test" ['T', 'E', 'S'])
             case result of
               Lost (MkWordState word missing) =>
                  putStrLn ("You lose. The word was " ++ word)
               Won game =>
                  putStrLn "You win!"


module Data.Map

%default total

export
data Map  : (key : Type) -> (VF : key -> Type) -> Type where
  MNil    : .{VF : key -> Type} -> Map key VF
  MBranch : (DecEq key, Ord key) =>
                       .{VF : key -> Type}
                    -> (k   : key)
                    -> (val : VF  k     )
                    -> (l   : Map key VF)
                    -> (r   : Map key VF)
                    -> Map key VF

%name Map map, map2, map3

empty : Map k p
empty = MNil

insert : (DecEq key, Ord key) => (k : key) -> p k -> Map key p -> Map key p
insert k x MNil = MBranch k x MNil MNil
insert k x (MBranch kr val l r) =
  case compare k kr of
    LT => MBranch kr val (insert k x l) r
    EQ => MBranch k x l r
    GT => MBranch kr val l (insert k x r)

lookup : (DecEq key, Ord key) => (k : key) -> Map key p -> Maybe (p k)
lookup _ MNil = Nothing
lookup k (MBranch kr val l r) =
  case decEq k kr of
    Yes prf => rewrite prf in Just val
    No  _   => case compare k kr of
                 LT => lookup k l
                 _  => lookup k r

insertWith : (DecEq key, Ord key) => (k : key) -> p k -> (p k -> p k -> p k) -> Map key p -> Map key p
insertWith k x f m =
  case lookup k m of
    Just v => insert k (f x v) m
    Nothing => insert k x m
-- it would be nice to implement this with one traversal,
-- but having a hard time rewriting some types
-- insertWith k x f MNil = MBranch k x MNil MNil
-- insertWith {p} k x f (MBranch kr val l r) =
--   case decEq kr k of
--     Yes prf => MBranch k (f x val) l r
--     No  _   => case compare k kr of
--                  LT => insertWith k x f l
--                  _  => insertWith k x f r

fromList : (DecEq key, Ord key) => List (k : key ** p k) -> Map key p
fromList [] = MNil
fromList ((k ** v) :: xs) = insert k v $ fromList xs


module Basic.Types.Qubit

import Data.Complex
import Data.Vect
import Effects
import Effect.Random
import Utils.Accomodation
import Utils.ComplexAddon

%default total
%access public export

record QuantumState a where
  constructor QS
  amplitude : Complex a
  label : String

%name QuantumState qs, qs1, qs2, qs3
implementation (Num a, Neg a, Show a, Eq a, Ord a)
                  => Show (QuantumState a) where
  show (QS amplitude label) = complexShow amplitude ++ "|" ++ label ++ ">" where
    complexShow : Complex a -> String
    complexShow (x :+ y) =
      if x == x + x
         then imShow y
         else if y <= y + y
                 then show x ++ "+" ++ imShow y
                 else show x ++ imShow y where
                      imShow : a -> String
                      imShow y =
                        if y > y + y
                           then "-" ++ imPosShow (negate y)
                           else imPosShow y where
                                imPosShow : (y : a) ->  String
                                imPosShow y = if y /= y + y
                                                 then if y * y == y
                                                         then "i"
                                                         else show y ++ "i"
                                                 else "0"

qMap : (f : Complex a -> Complex b) -> QuantumState a -> QuantumState b
qMap f (QS amplitude label) = QS (f amplitude) label

implementation Eq a => Eq (QuantumState a) where
  (QS amplitude1 label1) == (QS amplitude2 label2) =
    (amplitude1 == amplitude2) && (label1 == label2)
implementation [vectorization] Eq a => Ord (QuantumState a) where
  compare (QS amplitude1 label1) (QS amplitude2 label2) = compare label1 label2

qPredicate : (p : Complex a -> Bool) -> QuantumState a -> Bool
qPredicate p (QS amplitude label) = p amplitude

conjugateQS : Neg a => QuantumState a -> QuantumState a
conjugateQS = qMap conjugate

record Qubit a where
  constructor QB
  states : List (QuantumState a)
%name Qubit qb, qb1, qb2, qb3
partial
implementation (Num a, Neg a, Show a, Eq a, Ord a)
                => Show (Qubit a) where
  show (QB [])                  = ""
  show (QB (x :: []))           = show x
  show (QB (x :: qb@(y :: xs))) = show x ++ " + "
    ++ show (QB qb)

toAmplList : Qubit a -> List (Complex a)
toAmplList (QB states) = map amplitude states

toLabelList : Qubit a -> List String
toLabelList (QB states) = map label states

fromList : List (Complex a) -> List String -> Qubit a
fromList xs ys = QB (zipWith QS xs ys)

refine : Ord a => Qubit a -> List (QuantumState a)
refine (QB states) = sort @{vectorization} states

toFineList : Eq a => Qubit a -> List (Complex a)
toFineList (QB states) = map amplitude (sort @{vectorization} states)

fromFineList : List (Complex a) -> Qubit a
fromFineList xs = QB (zipWith QS xs (accomod "01" (degree (length xs) 2)))

liftQubit : (f : List (QuantumState a) -> List (QuantumState b))
              -> Qubit a -> Qubit b
liftQubit f (QB states) = QB (f states)

infix 2 <~>
(<~>) : Neg a => QuantumState a -> QuantumState a -> QuantumState a
(QS amplitude1 label1) <~> (QS amplitude2 label2) =
  QS (amplitude1 * amplitude2) (label1 ++ label2)

entangle : Neg a => Qubit a -> Qubit a -> Qubit a
entangle (QB states1) (QB states2) = QB [|states1 <~> states2|]

conjugateQubit : Neg a => Qubit a -> Qubit a
conjugateQubit = liftQubit (map conjugateQS)

scalarProduct : (Neg a, Eq a) => Qubit a -> Qubit a -> a
scalarProduct qb1 qb2 = realPart
                        (sum
                          (Prelude.List.zipWith (*)
                                                (toFineList qb1)
                                                (toFineList qb2)))

norm : (Cast a Double, Cast Double a, Neg a, Eq a) => Qubit a -> a
norm qb = (cast . sqrt . cast) (scalarProduct qb (conjugateQubit qb))

normalize : (Cast a Double, Cast Double a, Neg a, Eq a, Fractional a) =>
            Qubit a -> Qubit a
normalize qb = liftQubit ((map . qMap)
             (cast .
             (\x => x / (((sqrt . cast)
                          (scalarProduct qb (conjugateQubit qb))):+0)) .
             cast)) qb

extract : (Cast a Double, Cast Double a, Neg a, Eq a) =>
          Qubit a -> Eff String [RND]
extract qb = helper (map cast (toAmplList qb)) (toLabelList qb) where
  helper : List (Complex Double) -> List String-> Eff String [RND]
  helper ampl labels = help (part 0 ampl) labels where
    part : Double -> List (Complex Double) -> List Double
    part prev [] = []
    part prev ((x :+ y) :: xs) = curr :: part curr xs where
      curr : Double
      curr = prev + x * x + y * y
    help : List Double -> List String -> Eff String [RND]
    help [] _            = pure "Nothing"
    help ds@(x :: xs) ys =
      do rand <- assert_total (rndInt 0 (transmute (last ds)))
         findAns (zip (map transmute ds) ys) rand
      where
        transmute : Double -> Integer
        transmute x = cast (1000000000 * x)
        findAns : List (Integer, String) -> Integer -> Eff String [RND]
        findAns [] _                 = pure "Nothing"
        findAns ((p, label) :: xs) r = case p < r of
                                            False => findAns xs r
                                            True  => pure label

qubitZero : Qubit Double
qubitZero = QB ([(QS (1 :+ 0) "0"),
                (QS (0 :+ 0) "1")])

qubitOne : Qubit Double
qubitOne = QB ([(QS (0 :+ 0) "0"),
                (QS (1 :+ 0) "1")])

qubitPlus : Qubit Double
qubitPlus = QB ([(QS ((1 / sqrt 2) :+ 0) "0"),
                 (QS ((1 / sqrt 2) :+ 0) "1")])

qubitMinus : Qubit Double
qubitMinus = QB ([(QS ((1    / sqrt 2) :+ 0) "0"),
                  (QS (((-1) / sqrt 2) :+ 0) "1")])

qubitPhiPlus : Qubit Double
qubitPhiPlus = QB ([(QS ((1 / sqrt 2) :+ 0) "00"),
                    (QS ((1 / sqrt 2) :+ 0) "11")])

qubitPhiMinus : Qubit Double
qubitPhiMinus = QB ([(QS ((1    / sqrt 2) :+ 0) "00"),
                     (QS (((-1) / sqrt 2) :+ 0) "11")])

qubitPsiPlus : Qubit Double
qubitPsiPlus = QB ([(QS ((1 / sqrt 2) :+ 0) "01"),
                    (QS ((1 / sqrt 2) :+ 0) "10")])

qubitPsiMinus : Qubit Double
qubitPsiMinus = QB ([(QS ((1    / sqrt 2) :+ 0) "01"),
                     (QS (((-1) / sqrt 2) :+ 0) "10")])


module Data.Scientific

import Data.Fin
import Data.List
import Data.Vect

||| Arbitrary precision coefficient for scientific notation in base b.
||| Representants are unique regarding (==) and there are no trailing zeros.
||| For a coefficient x this holds:
|||   1 <= x < b
public export
data Coefficient : (b : Nat) -> Type where
  CoeffInt : Fin (S b) ->
             Coefficient (S (S b))
  CoeffFloat : Fin (S b) ->
               List (Fin (S (S b))) ->
               Fin (S b) ->
               Coefficient (S (S b))

public export
Uninhabited (Coefficient 0) where
  uninhabited _ impossible
public export
Uninhabited (Coefficient 1) where
  uninhabited _ impossible

public export
Eq (Coefficient b) where
  (CoeffInt x) == (CoeffInt y) = x == y
  (CoeffFloat x xs x') == (CoeffFloat y ys y') = x == y && xs == ys && x' == y'
  _ == _ = False

public export
Ord (Coefficient b) where
  compare (CoeffInt x) (CoeffInt y) = compare x y
  compare (CoeffInt x) (CoeffFloat y ys y') = case compare x y of
                                               EQ => LT
                                               comp => comp
  compare (CoeffFloat x xs x') (CoeffInt y) = case compare x y of
                                               EQ => GT
                                               comp => comp
  compare (CoeffFloat x xs x') (CoeffFloat y ys y') =
    compare (FS x :: xs `snoc` FS x') (FS y :: ys `snoc` FS y')

private
prettyShowDigit : Fin 10 -> Char
prettyShowDigit x =
  case x of
       0 => '0'
       1 => '1'
       2 => '2'
       3 => '3'
       4 => '4'
       5 => '5'
       6 => '6'
       7 => '7'
       8 => '8'
       9 => '9'

private
prettyShowCoefficient : Coefficient 10 -> String
prettyShowCoefficient (CoeffInt x) = pack [ prettyShowDigit (FS x) ]
prettyShowCoefficient (CoeffFloat x xs x') =
  pack $ [ prettyShowDigit (FS x), '.' ] ++ map prettyShowDigit xs ++ [ prettyShowDigit (FS x') ]

public export
data Sign = Positive
          | Negative

public export
Eq Sign where
  Positive == Positive = True
  Negative == Negative = True
  _ == _ = False

public export
Ord Sign where
  compare Positive Positive = EQ
  compare Positive Negative = GT
  compare Negative Positive = LT
  compare Negative Negative = EQ

private
prettyShowSign : Sign -> String
prettyShowSign s = case s of
                        Positive => ""
                        Negative => "-"

||| A scientific notation numeral in base b.
||| Representants are unique, as this type is built on top of Coefficient.
||| The numbers x represented are those which can be written as a finite sum of powers of b:
|||   x = \Sigma_{i=n}^m a_i * b^i          , {n,m : Integer; a_i : Fin b}
public export
data Scientific : (b : Nat) -> Type where
  SciZ : Scientific (S (S b))
  Sci : Sign ->
        Coefficient b ->
        Integer ->
        Scientific b

public export
Uninhabited (Scientific 0) where
  uninhabited (Sci _ _ _) impossible

public export
Uninhabited (Scientific 1) where
  uninhabited (Sci _ _ _) impossible

public export
Eq (Scientific b) where
  SciZ == SciZ = True
  (Sci s c e) == (Sci s' c' e') = s == s' && c == c' && e == e'
  _ == _ = False

public export
Ord (Scientific b) where
  compare SciZ SciZ = EQ
  compare SciZ (Sci s _ _) = case s of
                                  Positive => LT
                                  Negative => GT
  compare (Sci s _ _) SciZ = case s of
                                  Positive => GT
                                  Negative => LT
  compare (Sci s c e) (Sci s' c' e') =
    case (s, s') of
         (Positive, Positive) => case compare e e' of
                                      EQ => compare c c'
                                      comp => comp
         (Positive, Negative) => GT
         (Negative, Positive) => LT
         (Negative, Negative) => case compare e' e of
                                      EQ => compare c' c
                                      comp => comp

infixl 9 ^
private
(^) : Nat -> Nat -> Nat
x ^ Z = 1
x ^ (S k) = x * (x ^ k)

private
digitsToNat : {b : _} -> List (Fin (S (S b))) -> Nat
digitsToNat [] = 0
digitsToNat (x::xs) = finToNat x + (S (S b)) * digitsToNat xs

export
toInteger : {b : _} -> Scientific b -> Maybe Integer
toInteger SciZ = Just 0
toInteger (Sci s c e) =
  if e >= 0
     then case c of
               CoeffInt x => Just $ withSign $ finToNat (FS x) * (b ^ integerToNat e)
               CoeffFloat x xs x' => let digits = reverse $ (FS x) :: xs ++ [FS x']
                                         e' = e - natToInteger (length (xs ++ [FS x']))
                                     in if e' >= 0
                                           then Just $ withSign $ digitsToNat digits * (b ^ integerToNat e')
                                           else Nothing
     else Nothing
where
  withSign : Nat -> Integer
  withSign = case s of
                  Negative => negate . natToInteger
                  Positive => natToInteger

export
negate : Scientific b -> Scientific b
negate SciZ = SciZ
negate (Sci s c e) = let s' = case s of
                                   Positive => Negative
                                   Negative => Positive
                     in Sci s' c e

export
abs : Scientific b -> Scientific b
abs SciZ = SciZ
abs (Sci _ c e) = Sci Positive c e

-- TODO: What happens, when Integer is negative? Low priority, since this is private.
||| The digits of an Integer, least significant first.
private
integerDigits : {b : _} -> Integer -> List (Fin (S (S b)))
integerDigits 0 = []
integerDigits x = d :: integerDigits r where
  d : Fin (S (S b))
  d = restrict (S b) x
  r : Integer
  r = x `div` natToInteger (S (S b))

||| Remove the zeros near the head of a list.
private
removeLeadingZeros : List (Fin (S (S b))) -> Maybe (Fin (S b), List (Fin (S (S b))))
removeLeadingZeros [] = Nothing
removeLeadingZeros (FZ :: xs) = removeLeadingZeros xs
removeLeadingZeros (FS x :: xs) = Just (x, xs)

private
fromDigits : List (Fin (S (S b))) -> Scientific (S (S b))
fromDigits ys =
  case removeLeadingZeros $ reverse ys of
       Nothing => SciZ
       Just (x, ys') => case removeLeadingZeros $ reverse ys' of
                            Nothing => Sci Positive (CoeffInt x) (cast $ length ys')
                            Just (x', xs) => Sci Positive (CoeffFloat x (reverse xs) x') (cast $ length ys')

export
fromFin : Fin (S (S b)) -> Scientific (S (S b))
fromFin FZ = SciZ
fromFin (FS x) = Sci Positive (CoeffInt x) 0

export
fromInteger : {b : _} -> Integer -> Scientific (S (S b))
fromInteger x = if x < 0
                   then negate $ fromIntegerPositive x
                   else fromIntegerPositive x
where
  fromIntegerPositive : Integer -> Scientific (S (S b))
  fromIntegerPositive = fromDigits . integerDigits . abs

export
fromNat : {b : _} -> Nat -> Scientific (S (S b))
fromNat = fromInteger . natToInteger

||| Single bit full adder in base (S (S b)).
private
plusBit : (op : Sign) ->
          {b : _} ->
          (carry : Bool) ->
          Fin (S (S b)) ->
          Fin (S (S b)) ->
          ((Fin (S (S b))), Bool)
plusBit op False x FZ = (x, False)
plusBit Positive True x FZ = case strengthen $ FS FZ of
                                  Nothing => (FZ, True)
                                  Just z => (z, False)
plusBit Negative True x FZ = case x of
                                  FZ => (last, True)
                                  FS z => (weaken z, False)
plusBit Positive carry x (FS y) = case strengthen $ FS x of
                                       Nothing => (fst $ plusBit Positive carry FZ (weaken y), True)
                                       Just z => plusBit Positive carry z (weaken y)
plusBit Negative carry x (FS y) = case x of
                                       FZ => (fst $ plusBit Negative carry last (weaken y), True)
                                       FS z => plusBit Negative carry (weaken z) (weaken y)

||| N bit full adder in base (S (S b)).
export
plusBits : (op : Sign) ->
           {b : _} ->
           (carry : Bool) ->
           Vect n (Fin (S (S b))) ->
           Vect n (Fin (S (S b))) ->
           (Vect n (Fin (S (S b))), Bool)
plusBits op carry [] [] = ([], carry)
plusBits op carry (x :: xs) (y :: ys) =
  let (z, carry') = plusBit op carry x y
      (zs, sign) = plusBits op carry' xs ys
  in (z :: zs, sign)

-- TODO: Add NonEmpty to result type.
||| All bits of a Coefficient, least significant first.
export
coefficientBits : Coefficient (S (S b)) -> List (Fin (S (S b)))
coefficientBits (CoeffInt x) = [FS x]
coefficientBits (CoeffFloat x xs x') = reverse $ FS x :: xs ++ [FS x']

-- TODO: get a definiton like this working:
--equalizeLength : a ->
--                 (xs : List a) ->
--                 (ys : List a) ->
--                 (Vect (max (length xs) (length ys)) a, Vect (max (length xs) (length ys)) a)
private
equalizeLength : a ->
                (n : _) ->
                (xs : List a) ->
                (ys : List a) ->
                (Vect n a, Vect n a)
equalizeLength a Z _ _ = ([],[])
equalizeLength a (S k) [] [] = let (ps, qs) = equalizeLength a k [] []
                               in (a :: ps, a :: qs)
equalizeLength a (S k) [] (y::ys) = let (ps, qs) = equalizeLength a k [] ys
                                    in (a :: ps, y :: qs)
equalizeLength a (S k) (x::xs) [] = let (ps, qs) = equalizeLength a k xs []
                                    in (x :: ps, a :: qs)
equalizeLength a (S k) (x::xs) (y::ys) = let (ps, qs) = equalizeLength a k xs ys
                                         in (x :: ps, y :: qs)

||| Wrapper for plusBits, adding padding regarding the exponent and trailing zeros.
private
plusBits' : (op : Sign) ->
            {b : _} ->
            (List (Fin (S (S b))), Integer) ->
            (List (Fin (S (S b))), Integer) ->
            (List (Fin (S (S b))), Bool)
plusBits' op (xs,xe) (ys,ye) =
  let n = max (length xs) (length ys)
      (xs'', ys'') = equalizeLength FZ n xs' ys'
      (zs, overflow) = plusBits op False (reverse xs'') (reverse ys'')
  in (toList zs, overflow) where
    xs' : List (Fin (S (S b)))
    xs' = reverse $ xs ++ replicate (integerToNat ye `minus` integerToNat xe) FZ
    ys' : List (Fin (S (S b)))
    ys' = reverse $ ys ++ replicate (integerToNat xe `minus` integerToNat ye) FZ

-- TODO: remove this or removeLeadingZeros
private
removeLeadingZeros' : List (Fin (S (S b))) -> (Nat, Maybe (Fin (S b), List (Fin (S (S b)))))
removeLeadingZeros' [] = (Z, Nothing)
removeLeadingZeros' (FZ :: xs) = let (n, res) = removeLeadingZeros' xs
                                 in (S n, res)
removeLeadingZeros' (FS x :: xs) = (Z, Just (x, xs))

||| Requires the digits to be ordered, least significant first.
||| Returns Coefficient and number of significant zeros.
private
fromDigits' : List (Fin (S (S b))) -> (Maybe (Coefficient (S (S b))), Nat)
fromDigits' ys =
  let (n, removedLeading) = removeLeadingZeros' $ reverse ys
  in case removedLeading of
          Nothing => (Nothing, n)
          Just (x, ys') => case removeLeadingZeros $ reverse ys' of
                               Nothing => (Just (CoeffInt x), n)
                               Just (x', xs) => (Just (CoeffFloat x (reverse xs) x'), n)

export
(+) : {b : _} -> Scientific (S (S b)) -> Scientific (S (S b)) -> Scientific (S (S b))
SciZ + y = y
x + SciZ = x
x@(Sci s c e) + y@(Sci s' c' e') =
  let (zs, bit) = plusBits' op (xs, e) (ys, e')
  in case op of
          Positive => let s'' = s
                          bits = if bit then [FS FZ] else [FZ]
                      in case fromDigits' $ zs ++ bits of
                              (Nothing, _) => SciZ
                              (Just c'', bitShift) => let e'' = max e e' + 1 - natToInteger bitShift
                                                      in Sci s'' c'' e''
          Negative => let s'' = if bit then s' else s
                      in case fromDigits' zs of
                              (Nothing, _) => SciZ
                              (Just c'', bitShift) => let e'' = max e e' - natToInteger bitShift
                                                      in Sci s'' c'' e''
where
  op : Sign
  op = if s == s'
          then Positive
          else Negative
  xs : List (Fin (S (S b)))
  xs = coefficientBits c
  ys : List (Fin (S (S b)))
  ys = coefficientBits c'

(-) : {b : _} -> Scientific (S (S b)) -> Scientific (S (S b)) -> Scientific (S (S b))
x - y = x + negate y

-- TODO
||| Multiply two Coefficients and return True in the Bool, when the product is greater than the base.
private
multCoefficents : {b : _} -> Coefficient (S (S b)) -> Coefficient (S (S b)) -> (Coefficient (S (S b)), Bool)
multCoefficents (CoeffInt x) (CoeffInt y) =
  case integerToFin res (S b) of
       Nothing => (CoeffInt $ restrict b res, True)
       Just fin => (CoeffInt fin, False)
where
  res : Integer
  res = (finToInteger x + 1) * (finToInteger y + 1) - 1
multCoefficents a@(CoeffInt x) b@(CoeffFloat y ys y') = multCoefficents b a
-- TODO: finish multCoefficents
multCoefficents (CoeffFloat x xs x') (CoeffInt y) = ?multCoefficents_rhs_2
multCoefficents (CoeffFloat x xs x') (CoeffFloat y ys y') = ?multCoefficents_rhs_3

export
(*) : {b : _} -> Scientific (S (S b)) -> Scientific (S (S b)) -> Scientific (S (S b))
SciZ * y = SciZ
x * SciZ = SciZ
(Sci s c e) * (Sci s' c' e') = Sci s'' c'' e'' where
  coefficientPair : (Coefficient (S (S b)), Bool)
  coefficientPair = multCoefficents c c'
  s'' : Sign
  s'' = if s == s'
           then Positive
           else Negative
  c'' : Coefficient (S (S b))
  c'' = fst coefficientPair
  e'' : Integer
  e'' = if snd coefficientPair
           then e + e' + 1
           else e + e'

-- -- TODO: implementations don't work because the base (S (S b)) isn't accessible in the method's context.
-- -- TODO: consider other implementations:
-- -- - Fractional might not terminate, because of infinite representation
-- -- - Integral doesn't sound like it would fit, but mod and div make still make sense
-- public export
-- Num (Scientific b) where
--   -- (+) = (+)
--   -- (*) = (*)
--   -- fromInteger = fromInteger

-- public export
-- Neg (Scientific b) where
--   -- negate = negate
--   -- (-) = (-)

-- public export
-- Abs (Scientific b) where
--   -- abs = abs

||| Create string representing using scientific notation.
export
prettyShowScientific : Scientific 10 -> String
prettyShowScientific SciZ = "0"
prettyShowScientific (Sci s c e) = prettyShowSign s ++ prettyShowCoefficient c ++ prettyExponent where
  prettyExponent : String
  prettyExponent = case e of
                        0 => ""
                        x => "e" ++ show x


module Metamorphic

-- Based on https://bitbucket.org/josh-hs-ko/MetamorphismsInAgda/raw/master/MetamorphismsInAgda.pdf

data AlgList : (a : Type) -> {s : Type} -> (f : a -> s -> s) -> (e : s) -> s -> Type where
  Nil : AlgList a f e e
  (::) : (x : a) -> {st : s} -> AlgList a f e st -> AlgList a f e (f x st)

codata CoAlgList : (b : Type) -> {s : Type} -> (g : s -> Maybe (b, s)) -> s -> Type where
  Empty : {st : s} -> g st = Nothing -> CoAlgList b g st
  Cons : (x : b) -> {st, st' : s} -> g st = Just (x, st') -> CoAlgList b g st' -> CoAlgList b g st

testAlgList : AlgList Nat (\x, s => x + s) 0 3
testAlgList = 1 :: 1 :: 1 :: Nil

testCoAlgList : (st : Nat) -> CoAlgList Nat (\x => Just (x, S x)) st
testCoAlgList st = Cons st Refl (testCoAlgList (S st))

fromLeftAlg : {a, s : Type} -> (s -> a -> s) -> a -> (s -> s) -> (s -> s)
fromLeftAlg f a s = s . flip f a

parameters (a : Type, b : Type, s : Type, f : s -> a -> s, g : s -> Maybe (b, s),
            sc : {x : a} -> {y : b} -> {st, st' : s} -> g st = Just (y, st') -> g (f st x) = Just (y, f st' x))

  cbp : (st : s) -> {h : s -> s} -> AlgList a (fromLeftAlg f) (\x => x) h -> CoAlgList b g (h st)
  cbp s [] with (g s) proof prf
    cbp s [] | Nothing = Empty (sym prf)
    cbp s [] | Just (y, s') = Cons y (sym prf) (cbp s' [])
  cbp s (a :: as) = cbp (f s a) as

  lemma : {st : s} -> {y : b} -> {st' : s} -> {h : s -> s} -> AlgList a (fromLeftAlg f) (\x => x) h -> g st = Just (y, st') -> g (h st) = Just (y, h st')
  lemma [] eq = eq
  lemma (a :: as) eq = lemma as (sc eq)

  stream : (st : s) -> {h : s -> s} -> AlgList a (fromLeftAlg f) (\x => x) h -> CoAlgList b g (h st)
  stream s as with (g s) proof prf
    stream s [] | Nothing  = Empty (sym prf)
    stream s (a :: as) | Nothing  = stream (f s a) as
    stream s as | Just (y, s') = Cons y (lemma as (sym prf)) (stream s' as)


import Data.Vect
import Data.Fin
import Language.Reflection

%language ElabReflection

data Ty : Type where
     Base : Type -> Ty
     Arrow : Ty -> Ty -> Ty

-- Ty can be translated to a host language type

interpTy : Ty -> Type
interpTy (Base t) = t
interpTy (Arrow s t) = (argTy : interpTy s) -> interpTy t

data HasType : Fin k -> Ty -> Vect k Ty -> Type where
     Stop : HasType FZ t (t :: gam)
     Pop  : HasType i t gam -> HasType (FS i) t (u :: gam)

data Lang : Vect k Ty -> Ty -> Type where
     Var : HasType i t gam -> Lang gam t
     Val : (x : interpTy a) -> Lang gam a
     Lam : (scope : Lang (s :: gam) t) -> Lang gam (Arrow s t)
     App : Lang gam (Arrow s t) -> Lang gam s -> Lang gam t;
     Op  : (interpTy a -> interpTy b -> interpTy c) ->
           Lang gam a -> Lang gam b -> Lang gam c

data Env : Vect n Ty -> Type where
     Nil : Env Nil
     (::) : (x : interpTy a) -> Env xs -> Env (a :: xs)

-- Find a value in an environment
lookupEnv : HasType i t gam -> Env gam -> Elab (interpTy t)
lookupEnv Stop (x :: xs) = pure x
lookupEnv (Pop var) (x :: env) = lookupEnv var env

interp : Env gam -> Lang gam t -> Elab (interpTy t)
interp env (Var x)
    = do res <- lookupEnv x env
         pure res
interp env (Val x) = pure x
interp env (Lam scope)
    = lambda _ (\val => interp (val :: env) scope)
interp env (App f a)
    = interp env f <*> interp env a
interp env (Op f x y) = f <$> interp env x <*> interp env y

%macro
eval : Env gam -> Lang gam t -> Elab (interpTy t)
eval = interp

testAdd : Lang gam (Arrow (Base Nat) (Arrow (Base Nat) (Base Nat)))
testAdd = Lam (Lam (Op plus (Var Stop) (Var (Pop Stop))))

evalAdd : Nat -> Nat -> Nat
evalAdd x y =let add = eval [] testAdd in add x y

testBlock : Lang gam (Base Nat)
testBlock = Op {a=Base Nat} {b=Base Nat} plus (Val 3) (Val 4)

evalBlock : Nat
evalBlock = eval [] testBlock


module PLFI.Part1.Connectives

import Data.Fin
import PLFI.Part1.Isomorphism
import Syntax.PreorderReasoning.Generic

-- data _×_ (A B : Set) : Set where

--   ⟨_,_⟩ :
--       A
--     → B
--       -----
--     → A × B

test : (Int,Nat)
test = (0,0)

total
test2 : (Void,Nat)
test2 = (?x,0)

-- data TT : Type where
--   MkTT : TT

-- data TF : Type where

-- test3 : TF
-- test3 = ?x1

-- test4 : (TT, TT)
-- test4 = (MkTT, MkTT)

-- test5 : (TF, TT)
-- test5 = (?test5_rhs_1, MkTT)

-- test6 : (,) Nat Nat
-- test6 = (3,3)

data Sx : Nat -> Type where
  MkSx : Sx n

test7 : (x : Nat ** Sx x)
test7 = (3 ** MkSx)

test8 : DPair Nat (\x => Sx x)
test8 = MkDPair 3 MkSx

-- test8 : Sigma Nat (\x => Sx x)
-- test8 = MkSigma 3 MkSx

-- η-× : ∀ {A B : Set} (w : A × B) → ⟨ proj₁ w , proj₂ w ⟩ ≡ w
etaTuple : {a,b : Type} -> (w : (a, b)) -> (fst w, snd w) === w
etaTuple (x, y) = Refl

-- data Bool : Set where
--   true  : Bool
--   false : Bool

-- data Tri : Set where
--   aa : Tri
--   bb : Tri
--   cc : Tri

data B : Type where
  True : B
  False : B

enumB : B -> Fin 2
enumB True = 0
enumB False = 1

-- data T : Type where
--   AA, BB, CC : T

-- enumT : T -> Fin 3
-- enumT AA = 0
-- enumT BB = 1
-- enumT CC = 2

tupleX : (a -> Fin n) -> (b -> Fin m) -> (a,b) -> Fin (n * m)
tupleX f s x = ?xy

-- timesCountBetween1and6 : (x: (Bool, Tri)) -> (timesCount x <= 6 && timesCount x >= 1) = True
-- timesCountBetween1and6 (False, Aa) = Refl
-- timesCountBetween1and6 (False, Bb) = Refl
-- timesCountBetween1and6 (False, Cc) = Refl
-- timesCountBetween1and6 (True, Aa) = Refl
-- timesCountBetween1and6 (True, Bb) = Refl
-- timesCountBetween1and6 (True, Cc) = Refl

-- ×-comm : ∀ {A B : Set} → A × B ≃ B × A
-- ×-comm =
--   record
--     { to       =  λ{ ⟨ x , y ⟩ → ⟨ y , x ⟩ }
--     ; from     =  λ{ ⟨ y , x ⟩ → ⟨ x , y ⟩ }
--     ; from∘to  =  λ{ ⟨ x , y ⟩ → refl }
--     ; to∘from  =  λ{ ⟨ y , x ⟩ → refl }
--     }

prodComm : Iso (a,b) (b,a)
prodComm =
  MkIso
    { to     = (\(x,y) => (y,x))
    , from   = (\(y,x) => (x,y))
    , fromTo = (\(x,y) => Refl)
    , toFrom = (\(y,x) => Refl)
    }

-- ×-assoc : ∀ {A B C : Set} → (A × B) × C ≃ A × (B × C)
-- ×-assoc =
--   record
--     { to      = λ{ ⟨ ⟨ x , y ⟩ , z ⟩ → ⟨ x , ⟨ y , z ⟩ ⟩ }
--     ; from    = λ{ ⟨ x , ⟨ y , z ⟩ ⟩ → ⟨ ⟨ x , y ⟩ , z ⟩ }
--     ; from∘to = λ{ ⟨ ⟨ x , y ⟩ , z ⟩ → refl }
--     ; to∘from = λ{ ⟨ x , ⟨ y , z ⟩ ⟩ → refl }
--     }

prodAssoc : Iso ((a,b),c) (a,(b,c))
prodAssoc = MkIso
  { to      = \((x,y),z) => (x,(y,z))
  , from    = \(x,(y,z)) => ((x,y),z)
  , fromTo  = \((x,y),z) => Refl
  , toFrom  = \(x,(y,z)) => Refl
  }

-- data ⊤ : Set where
--   tt :
--     --
--     ⊤

data T : Type where
  TT : T

-- ------ T-I
-- TT : T

--  T , c
-- ------- T-E
--    c

-- elim:
-- c -> (T -> c)
-- c -> T -> c
-- c -> c

-- ⊤-identityˡ : ∀ {A : Set} → ⊤ × A ≃ A
-- ⊤-identityˡ =
--   record
--     { to      = λ{ ⟨ tt , x ⟩ → x }
--     ; from    = λ{ x → ⟨ tt , x ⟩ }
--     ; from∘to = λ{ ⟨ tt , x ⟩ → refl }
--     ; to∘from = λ{ x → refl }
--     }

ttIdentityL : {a : Type} -> Iso (T, a) a
ttIdentityL = MkIso
  { to     = \(TT,y) => y
  , from   = \x => (TT, x)
  , fromTo = \(TT,y) => Refl
  , toFrom = \y => Refl
  }

-- ⊤-identityʳ : ∀ {A : Set} → (A × ⊤) ≃ A
-- ⊤-identityʳ {A} =
--   ≃-begin
--     (A × ⊤)
--   ≃⟨ ×-comm ⟩
--     (⊤ × A)
--   ≃⟨ ⊤-identityˡ ⟩
--     A
--   ≃-∎

-- 0
test3 : {a,b,c : Type} -> Iso a b -> Iso b c -> Iso a c
test3 ab bc = CalcWith {leq = Iso} $
  |~ a
  <~ b ... (ab)
  <~ c ... (bc)

ttIdentityR : {a : Type} -> Iso (a,T) a
ttIdentityR = CalcWith {leq = Iso} $
  |~ (a, T)
  <~ (T, a)  ... prodComm
  <~ a       ... ttIdentityL

-- Same as Either, we are going to use Either
data Sum : Type -> Type -> Type where
  L : a -> Sum a b
  R : b -> Sum a b

-- the first introduces a formula for the connective, which appears in the conclusion but not in the hypotheses
--     x : a
-- ------------- Sum-I1
-- L x : Sum a b
--
--     x : b
-- ------------- Sum-I2
-- R x : Sum a b

-- the second eliminates a formula for the connective, which appears in a hypothesis but not in the conclusion
-- Sum a b , (a -> c) , (b -> c)
-- ----------------------------- Sum-E
--              c

-- case-⊎ : ∀ {A B C : Set}
--   → (A → C)
--   → (B → C)
--   → A ⊎ B
--     -----------
--   → C
-- case-⊎ f g (inj₁ x) = f x
-- case-⊎ f g (inj₂ y) = g y

-- either

-- η-⊎ : ∀ {A B : Set} (w : A ⊎ B) → case-⊎ inj₁ inj₂ w ≡ w

either2 : (b -> c) -> (a -> c) -> Either a b -> c
either2 f g (Left x) = g x
either2 f g (Right x) = f x

etaEither : {a,b : Type} -> (w : Either a b) -> either Left Right w = w
etaEither (Left x) = Refl
etaEither (Right x) = Refl

testData1 : Either () Nat
testData1 = Right 1

test1 : Bool
test1 = either Left Right testData1 == (Right 1)

testData2 : Either Nat ()
testData2 = Left 2

test4 : Bool
test4 = either Left Right testData2 == (Left 2)

-- uniq-⊎ : ∀ {A B C : Set} (h : A ⊎ B → C) (w : A ⊎ B) →
uniqEither
  :  {a,b,c : Type} -> (h : Either a b -> c) -> (w : Either a b)
  -> either (h . Left) (h . Right) w = h w
uniqEither h (Left x) = Refl
uniqEither h (Right x) = Refl

-- test5 : let t = Nat = Nat in Either t t
-- test5 = Left Refl

commEither : Iso (Either a b) (Either b a)
commEither = MkIso
  { to     = either Right Left
  , from   = either Right Left
  , fromTo = \case
                (Left x) => Refl
                (Right x) => Refl
  , toFrom = \case
                (Left x) => Refl
                (Right x) => Refl
  }

assocEither : Iso (Either (Either a b) c) (Either a (Either b c))
assocEither = MkIso
  { to     = either (either Left (Right . Left)) (Right . Right)
  , from   = either (Left . Left) (either (Left . Right) Right)
  , fromTo = \case
                (Left (Left x))   => Refl
                (Left (Right x))  => Refl
                (Right x)         => Refl
  , toFrom = \case
                (Left x)          => Refl
                (Right (Left x))  => Refl
                (Right (Right x)) => Refl
  }

-- Couldn't parse any alternatives:
-- 1: Expected name.
-- ... (1 others)idris2
-- data G : Type where
--   { MkG : G
--   } -- c)

-- Without where clause it means something else, we declare this type, but we don't define it yet.
-- data F : Type          a)
-- declare data F : Type  a)

-- Suggestions for definition of empty type
-- data F : Type where -- b)

-- data F : Type where -- c)
--   impossible

-- data F : Type empty -- d)

-- data F : Type impossible -- e)

-- data F : Type where {}

data F : Type where -- c)

fElim : {0 a : Type} -> F -> a
fElim x impossible

fElim' : {a : Type} -> F -> a
fElim' = \x => case x of {} -- \case leads to a parse error

-- uniq-⊥ : ∀ {C : Set} (h : ⊥ → C) (w : ⊥) → ⊥-elim w ≡ h w
-- uniq-⊥ h ()

uniqF : {c : Type} -> (h : F -> c) -> (w : F) -> fElim w = h w
uniqF h w impossible

-- ⊥-identityˡ

fIdentityL : Iso (Either F a) a
fIdentityL = MkIso
  { to     = either fElim id
  , from   = Right
  , fromTo = \case
                (Left x) => fElim x
                (Right x) => Refl
  , toFrom = \y => Refl
  }

fIdentityR : Iso (Either a F) a
fIdentityR = isoTrans commEither fIdentityL

-- η-→ : ∀ {A B : Set} (f : A → B) → (λ (x : A) → f x) ≡ f
-- η-→ f = refl

-- TODO: Ask
--    a : Type
--    b : Type
--    f : a -> b
-- ------------------------------
-- xx : (\x => f x) = f
etaFun : {a,b : Type} -> (f : a -> b) -> (\x => f x) = f
etaFun f = Refl

--    a : Type
--    b : Type
--    f : a -> b
-- ------------------------------
-- xRefl : (\x => f x) = (\y => f y)
alphaFun : {a,b : Type} -> (f : a -> b) -> (\x => f x) = (\y => f y)
alphaFun f = Refl

-- Under the hood terms are normalized for alpha/eta equivalence?
alphaFun2 : {a,b,c : Type} -> (f : a -> b -> c) -> (z : b) -> (\x => f x z) = (\y => f y z)
alphaFun2 f z = Refl

betaFun : (y : Nat) -> (\x => x * x) y = y * y
betaFun y = Refl

namespace Newtype12

  export
  Person : Type
  Person = (String, Int)

  public export
  mkPerson : (String, Int) -> Person
  mkPerson = id

  public export
  unPerson : Person -> (String, Int)
  unPerson = id

  export
  0
  samePersonLemma : (p : Person) -> (mkPerson (unPerson p)) = p
  samePersonLemma p = Refl

  -- export
  -- samePersonLemma

test5 : Person
test5 = mkPerson ("Andor", 23)

-- samePersonLemma : (p : Person) -> (mkPerson (unPerson p)) = p
-- samePersonLemma p = Refl

samePersonLemmaR : (p : (String, Int)) -> (unPerson (mkPerson p) = p)
samePersonLemmaR p = ?h1_0

handwaving : {t : Type} -> (a : t) -> (b : t) -> (a = b)
handwaving a b = believe_me (the (a=a) Refl)

namespace Postulate

  export
  extensionality : {a,b : Type} -> {f,g : a -> b} -> ((x : a) -> f x = g x) -> f = g
  extensionality _ = handwaving f g

-- currying : ∀ {A B C : Set} → (A → B → C) ≃ (A × B → C)
currying : {a,b,c : Type} -> Iso (a -> b -> c) ((a,b) -> c)
currying = MkIso
  { to      = \f => \(x,y) => f x y
  , from    = \f => \x => \y => f (x, y)
  , fromTo  = \f => Refl
  , toFrom  = \g => extensionality (\(x,y) => Refl)
  }

-- c ^ (a + b) ~ c ^ a * c ^ b
-- →-distrib-⊎ : ∀ {A B C : Set} → (A ⊎ B → C) ≃ ((A → C) × (B → C))
distribFunOverSumR : {a,b,c : Type} -> Iso (Either a b -> c) (a -> c, b -> c)
distribFunOverSumR = MkIso
  { to     = \f     => (f . Left, f . Right)
  , from   = \(f,g) => either f g
  , fromTo = \f     => extensionality (\case { Left x => Refl ; Right y => Refl })
  , toFrom = \(f,g) => Refl
  }

-- →-distrib-× : ∀ {A B C : Set} → (A → B × C) ≃ (A → B) × (A → C)
-- (p * n) ^ m = (p ^ m) * (n ^ m)
distribFunOverProdL : {a,b,c : Type} -> Iso (a -> (b,c)) (a -> b, a -> c)
distribFunOverProdL = MkIso
  { to     = \f     => (fst . f, snd . f)
  , from   = \(f,g) => \x => (f x, g x)
  , fromTo = \f     => extensionality (\x => etaTuple (f x)) -- TODO: Next time cong
  , toFrom = \(f,g) => Refl
  }

-- →-distrib-× : ∀ {A B C : Set} → (A → B × C) ≃ (A → B) × (A → C)
-- (p * n) ^ m = (p ^ m) * (n ^ m)
distribFunOverProdL2 : {a,b,c : Type} -> Iso (a -> (b,c)) (a -> b, a -> c)
distribFunOverProdL2 = MkIso
  { to     = \f     => (fst . f, snd . f)
  , from   = \(f,g) => \x => (f x, g x)
  , fromTo = \f     => extensionality (\x => cong id (cong id (cong id (etaTuple (f x)))))
  , toFrom = \(f,g) => Refl
  }

-- ×-distrib-⊎ : ∀ {A B C : Set} → (A ⊎ B) × C ≃ (A × C) ⊎ (B × C)
distribProdOverSum  : {a,b,c : Type} -> Iso (Either a b, c) (Either (a,c) (b,c))
distribProdOverSum = MkIso
  { to = \(x,y) => bimap (,y) (,y) x
  , from = either (mapFst Left) (mapFst Right)
  -- , fromTo = \(x, y) => either (\z => ?h1) ?h2 x -- (const Refl) (const Refl) x
  , fromTo = \(x, y) => case x of
                (Left z) => Refl
                (Right z) => Refl
  , toFrom = \case
                (Left (x, y)) => Refl
                (Right (x, y)) => Refl
  }

-- ⊎-distrib-× : ∀ {A B C : Set} → (A × B) ⊎ C ≲ (A ⊎ C) × (B ⊎ C)
weakDistribSumOverProd : {a,b,c : Type} -> (Either (a,b) c) <= (Either a c, Either b c)
weakDistribSumOverProd = MkEmb
  { to = \case
            (Left (x, y)) => (Left x, Left y)
            (Right x) => (Right x, Right x)
  , from = \case
              ((Right x), y        ) => Right x
              ((Left x) , (Right y)) => Right y
              ((Left x) , (Left y) ) => Left (x, y)
  , fromTo = \case
                (Left (x, y)) => Refl
                (Right x) => Refl
  }


module Main

import Effect.Random
import Effect.StdIO
import Effects
import Data.Vect

-- import Probability.Core
-- import Probability.Monad

%default total

{- Probabilistic programming -}

data Prob : Type -> Type where
  Binomial : Nat -> Double -> Prob Nat
  Certainly : a -> Prob a
  Bind : (Prob a) -> (a -> Prob b) -> Prob b
  CustomDist : Vect (S n) (a, Double) -> Prob a

Show a => Show (Prob a) where
  show (Binomial n p) = "Binomial " ++ (show n) ++ " " ++ (show p)
  show (Certainly a) = "Certainly " ++ (show a)
  show (Bind (Binomial n p) _) = "Bind (" ++ (show $ Binomial n p) ++ ") <function>"
  show (Bind a _) = "Bind <dist> <function>"
  show (CustomDist d) = "CustomDist " ++ (show d)

-- NOTE: It seems Idris won't accept this as total unless I handle the
-- 'impossible' case (that's also why choose wasn't reducing at compile time).
zeroSum : {a: Nat} -> {b: Nat} -> (a + b = 0) -> Either Void ((a = 0), (b = 0))
zeroSum {a = Z} Refl = Right (Refl, Refl)
zeroSum {a} {b = Z} prf = Right (replace {P = \x => x = 0} (plusZeroRightNeutral a) prf, Refl)
zeroSum {a = S a} {b = S b} prf = Left $ SIsNotZ prf

factNZ : {k: Nat} -> Not (fact k = Z)
factNZ {k = Z} p = SIsNotZ p
factNZ {k = (S k)} p = case zeroSum p of
  Left v => v
  Right (q1, _) => factNZ q1

-- factBetween : Nat -> Nat -> Nat
-- factBetween n m = if n == m then n else if n > m then 0 else  (factBetween n (pred m)) * (m)

total
choose : Nat -> Nat -> Nat
choose _ Z = 1
choose (S n) (S Z) = S n
choose Z (S _) = 0
-- if n < k then n `choose` k = 0
choose n k = divNatNZ (divNatNZ (fact n) (fact (n `minus` k)) factNZ) (fact k) factNZ

chooseZero : {n: Nat} -> choose n Z = 1
chooseZero = Refl

chooseOne : {n: Nat} -> choose (S n) 1 = S n
chooseOne = Refl

-- chooseNLessK : choose n (n + m + 1) = 0
-- chooseNLessK = ?csdvsd

total
binomialPMF : Nat -> Double -> Nat -> Double
binomialPMF n p k = cast (n `choose` k) * (p `pow` k) * ((1.0 - p) `pow` (n `minus` k))

splitBy : (a -> Bool) -> List a -> (List a, List a)
splitBy _ [] = ([], [])
splitBy pred (x::xs) = let (s, t) = splitBy pred xs in
  if pred x then (x::s, t) else (s, x::t)

gatherer : (Eq a, Eq p, Num p) => List (a,p) -> List (a,p) -- copied from https://github.com/lambdacasserole/probability/blob/master/src/Probability/Core.idr
gatherer [] = []
gatherer ((x,p) :: xs) = assert_total $  -- why is assert_total needed?
   let lyln = splitBy (\(z,_) => z == x) xs
       newp = (+) p . sum $ map snd (fst lyln)
   in  (x,newp) :: gatherer (snd lyln)

-- vectNatEnumFromTo : (a, b: Nat) -> {auto prf: LTE a b} -> Vect (b - a + 1) Nat
-- vectNatEnumFromTo a b = vectNatEnumFromTo' a (b - a) where
--   vectNatEnumFromTo' a Z = [a]
--   vectNatEnumFromTo' a (S n) = a :: vectNatEnumFromTo' (a + 1) n

-- cartesianProduct : Vect n a -> (a -> Vect m b) -> Vect (n * m) (a, b)
-- cartesianProduct [] _ = []
-- cartesianProduct {n} {m = Z} _ _ = rewrite multZeroRightZero n in []
-- cartesianProduct (x::xs) fys = ((\y => (x, y)) <$> fys x) ++ cartesianProduct xs fys
--
-- cartesianProduct' : Vect n a -> (a -> (m: Nat ** Vect m b)) -> Vect (n * m) (a, b)
-- cartesianProduct' xs fys = cartesianProduct xs (DPair.snd . fys)

concatNonempty' : Vect n (m: Nat ** Vect (S m) a) -> (k: Nat ** Vect k a)
concatNonempty' [] = (_ ** [])
concatNonempty' (x1::xs) = (_ ** (snd x1) ++ (snd (concatNonempty' xs)))

concatNonempty : Vect (S n) (m: Nat ** Vect (S m) a) -> (k: Nat ** Vect (S k) a)
concatNonempty [x] = x
-- concatNonempty [x1, x2] = (_ ** (snd x1) ++ (snd x2))
concatNonempty (x1::xs) = (_ ** (snd x1) ++ (snd (concatNonempty' xs)))

total
runProb : Prob a -> (k: Nat ** Vect (S k) (a, Double))
runProb (Binomial n p) = (_ ** (\k => (k, binomialPMF n p k)) <$> 0 :: fromList [1..n])
runProb (Certainly a) = (_ ** [(a, 1.0)])
-- runProb {a} (Bind probA f) = (_ ** (\((_,w),(y,q)) => (y, q*w)) <$> cartesianProduct {m = m} (DPair.snd {x = runProb probA}) f'') where
--   f' : (a: Type) -> (b, Double) -> (l: Nat ** Vect (S l) (a, Double))
--   f' a (y,_) = runProb {a = a} ?dxdv --(f x)
--   f'' y' = DPair.snd {x = (f' a y')}
--   m = S $ DPair.fst (f' (head (DPair.snd (runProb probA))))
runProb {a} (Bind probA f) =
  concatNonempty (snd joinedPartly) -- unjoined = (\(pA,p) => (runProb pA, p)) <$> probfAs in
  where
    probfAs : (k: Nat ** Vect (S k) ((l: Nat ** Vect (S l) (a, Double)), Double))
    probfAs = assert_total (_ ** (\(x,p) => (runProb (f x), p)) <$> snd (runProb (assert_smaller (Bind probA f) probA)))
    joinedPartly : (k: Nat ** Vect (S k) (l: Nat ** Vect (S l) (a, Double)))
    joinedPartly = (_ ** (\((_**dist),p) => (_ ** (\(x,q) => (x, p*q)) <$> dist)) <$> snd probfAs)
    -- joinedPartly = (_ ** ?cbfdbdb <$> probfAs)
runProb (CustomDist d) = (_ ** d)

Functor Prob where
  map f (Certainly a) = Certainly $ f a
  map f (Bind a g) = Bind a (\x => f <$> g x)
  map f (CustomDist d) = CustomDist $ (\(x, p) => (f x, p)) <$> d
  map f p = CustomDist $ (\(x, p) => (f x, p)) <$> (snd $ runProb p)

Applicative Prob where
  pure = Certainly
  (Certainly f) <*> p = f <$> p
  (Bind pa f) <*> p = Bind pa (\a => (f a) <*> p)
  -- (CustomDist d) <*> p = CustomDist [ (f x, q*w) | (f,w) <- d, (x,q) <- runProb p ] -- copied from https://github.com/lambdacasserole/probability/blob/master/src/Probability/Core.idr
  (CustomDist d) <*> p = Bind (CustomDist d) (\f => Bind p (pure . f))

Monad Prob where
  (Certainly a) >>= f = f a
  (Bind fa f) >>= g = fa >>= (\a => (f a) >>= g)
  fa >>= f = Bind fa f

gather : (Eq a) => Prob a -> Prob a
-- FIXME: Adapt this function for vects
-- gather (CustomDist d) = CustomDist (gatherer d)
-- gather (Bind pa f) = pa >>= (\a => gather $ f a) -- FIXME: Might not gather completely because pa not gathered
gather p = p

mortalityRate : Double
mortalityRate = 0.03

binomial : Nat -> Double -> Prob Nat
binomial = Binomial

kill : (population: Nat) -> Double -> Prob Nat
kill = binomial

replace : Nat -> Nat -> Prob (Nat, Nat)
replace n1 n2 = gather $ replace' <$> binomial (n1 + n2) ((cast n1) / (cast (n1 + n2))) where
  replace' n1' = (n1', (n1 + n2) `minus` n1')

step : Nat -> Nat -> Prob (Nat, Nat)
step n1 n2 = gather $ do
  dead1 <- kill n1 mortalityRate
  dead2 <- kill n2 mortalityRate
  gather $ (\(new1,new2) => ((n1 `minus` dead1) + new1, (n2 `minus` dead2) + new2)) <$> replace dead1 dead2

simulate : Nat -> Nat -> Nat -> Prob (Nat, Nat)
simulate species1Initial species2Initial Z = pure (species1Initial, species2Initial)
simulate species1Initial species2Initial (S k) = gather $ do
  (n1, n2) <- step species1Initial species2Initial
  gather $ simulate n1 n2 k

{- Error propagation -}

data Uncertain value = MkUncertain value value

interface SquareRootable a where
  sqrt : a -> a

SquareRootable Double where
  sqrt = Doubles.sqrt

square : Num a => a -> a
square a = a * a

norm : (Num a, SquareRootable a) => List a -> a
norm values = sqrt $ sum (square <$> values)

(Fractional value, SquareRootable value) => Num (Uncertain value) where
  -- FIXME: Account for correlation
  (+) (MkUncertain a aUncertainty) (MkUncertain b bUncertainty) = MkUncertain (a + b) (norm [aUncertainty, bUncertainty])
  (*) (MkUncertain a aUncertainty) (MkUncertain b bUncertainty) = (MkUncertain (a * b) (a * b * norm [aUncertainty/a, bUncertainty/b]))
  fromInteger i = MkUncertain (fromInteger i) 0

(SquareRootable value, Fractional value) => Fractional (Uncertain value) where
  (MkUncertain a aUncertainty) / (MkUncertain b bUncertainty) = MkUncertain (a / b) (a / b * norm [aUncertainty/a, bUncertainty/b])

Show value => Show (Uncertain value) where
  show (MkUncertain a aUncertainty) = show a ++ " +- " ++ show aUncertainty

interface Scalable a where
  (*) : a -> Double -> a

Scalable Double where
  (*) = Interfaces.(*)

mean : (Scalable a, Num a) => (prob: Prob a) -> a
mean (Binomial n p) = (Main.(*) n p) -- probably not what you want
mean (Certainly a) = a
mean (CustomDist d) = sum [x * p | (x, p) <- d]
mean (Bind pa f) = sum [x * p | (x, p) <- snd $ runProb (pa >>= f)]

-- population standardDeviation (QUESTION: should it be sample instead?)
standardDeviation : (SquareRootable a, Scalable a, Neg a) => (prob: Prob a) -> a
standardDeviation (Binomial n p) = sqrt (Main.(*) (Main.(*) n p) (1.0 - p)) -- probably not what you want
standardDeviation (Certainly _) = 0
standardDeviation (CustomDist d) = let mu = mean (CustomDist d) in
  sqrt $ sum [square (mu - x) * p | (x, p) <- d]
standardDeviation (Bind pa f) = let mu = mean (Bind pa f) in
  sqrt $ sum [square (mu - x) * p | (x, p) <- snd $ runProb (pa >>= f)]

probToUncertain : (SquareRootable a, Scalable a, Neg a, Fractional a) => (prob: Prob a) -> Uncertain a
probToUncertain dist = MkUncertain (mean dist) (Main.(*) (standardDeviation dist) 0.5)

{- Estimate distributions by sampling (Monte Carlo) -}

select : Double -> Vect (S n) (a, Double) -> Double -> a
select _ [(x, p)] _ = x
select target ((x, p)::xps) current =
  if target >= current + p
    then x
    else case xps of
      [] => x
      (xp::xps') => select target (xp::xps') (current + p)

-- Copied from https://bl.ocks.org/justinmanley/f2e169feb32e06e06c2f
||| Naively generate a (pseudo)-random float between 0 and 1.
rndDouble : Integer -> Eff Double [RND]
rndDouble max = do
	rnd <- assert_total $ rndInt 0 max
	pure (fromInteger rnd / fromInteger max)

sample : Prob a -> Eff a [RND, STDIO]
sample (Bind prob f) = do
  observedFromProb <- sample prob
  putStrLn "Bind: sampled prob"
  result <- sample (f observedFromProb)
  putStrLn "Bind: sampled f _"
  pure result
sample prob = do
  putStrLn "Sampling from an arbitrary distribution"
  probability <- rndDouble (2 `pow` 20)
  (_ ** dist) <- pure (runProb prob)
  pure $ select probability dist 0.0

Applicative (Pair Int) where
  pure a = (0, a)

  f <*> fa = (fst fa, (snd f) (snd fa))

main : IO ()
main = do
  dist <- pure (simulate 1 1 3)
  putStrLn "dist"
  printLn dist
  printLn (gatherer $ toList (snd (runProb dist)))
  printLn $ (MkUncertain 0.172807 0.000008) / ((MkUncertain 13.7 0.3) * (MkUncertain 1.0 0.1)) -- 0.013 ± 0.001 (https://chem.libretexts.org/Bookshelves/Analytical_Chemistry/Supplemental_Modules_(Analytical_Chemistry)/Quantifying_Nature/Significant_Digits/Propagation_of_Error)
  printLn $ probToUncertain (cast {to=Double} <$> binomial 5 0.5) -- 2.5 +- 0.559
  -- printLn (run $ sample (simulate 1 1 3))


module FieldAxioms

import ZZ
import ZZUtils
import GCDZZ
import Divisors
import Rationals

%default total

-- The field axioms which require the custom equality EqRat type are verified here.

EqRatAddInvLeft: (x: ZZPair) -> (a: NotZero (snd x))
-> (EqRat (AddRationals x a (AddInverse x a) (xAndInverseNotZeroPlus x a)) (productNonZero a (xAndInverseNotZeroPlus x a)) ((Pos 0), (snd x)*(snd x)) (productNonZero a a))
EqRatAddInvLeft x a = eqMeansEqRat (AddRationals x a (AddInverse x a) (xAndInverseNotZeroPlus x a)) (productNonZero a (xAndInverseNotZeroPlus x a)) ((Pos 0), (snd x)*(snd x)) (productNonZero a a) (addInverseLeft x a)

EqRatAddInvRight: (x: ZZPair) -> (a: NotZero (snd x))
-> (EqRat (AddRationals (AddInverse x a) (xAndInverseNotZeroPlus x a) x a) (productNonZero a (xAndInverseNotZeroPlus x a)) ((Pos 0), (snd x)*(snd x)) (productNonZero a a))
EqRatAddInvRight x a = eqMeansEqRat (AddRationals (AddInverse x a) (xAndInverseNotZeroPlus x a) x a) (productNonZero a (xAndInverseNotZeroPlus x a)) ((Pos 0), (snd x)*(snd x)) (productNonZero a a) (addInverseRight x a)

EqRatMultInvLeft: (x: ZZPair) -> (a: NotZero (fst x)) -> (b: NotZero (snd x))
-> (EqRat (MultiplyRationals x b (MultInverse x a b) (xAndInverseNotZeroMult x a b)) (productNonZero b (xAndInverseNotZeroMult x a b)) ((fst x)*(snd x), (fst x)*(snd x)) (productNonZero a b))
EqRatMultInvLeft x a b = eqMeansEqRat (MultiplyRationals x b (MultInverse x a b) (xAndInverseNotZeroMult x a b)) (productNonZero b (xAndInverseNotZeroMult x a b)) ((fst x)*(snd x), (fst x)*(snd x)) (productNonZero a b) (multInverseLeft x a b)

EqRatMultInvRight: (x: ZZPair) -> (a: NotZero (fst x)) -> (b: NotZero (snd x))
-> (EqRat (MultiplyRationals (MultInverse x a b) (xAndInverseNotZeroMult x a b) x b) (productNonZero (xAndInverseNotZeroMult x a b) b) ((snd x)*(fst x), (snd x)*(fst x)) (productNonZero b a))
EqRatMultInvRight x a b = eqMeansEqRat (MultiplyRationals (MultInverse x a b) (xAndInverseNotZeroMult x a b) x b) (productNonZero (xAndInverseNotZeroMult x a b) b) ((snd x)*(fst x), (snd x)*(fst x)) (productNonZero b a) (multInverseRight x a b)

-- All of the following proofs involve the use of EqRat and its associated properties which are
-- reflexvity, symmetry, transitivity, and the fact that two elements being equal is enough to construct
-- an element of EqRat.

|||Constructs an equality between (a,b) + (c,d) and (c,d) + (a,b)
plusCommQEqRat: (x: ZZPair) -> (a: NotZero (snd x)) -> (y: ZZPair) -> (b: NotZero (snd y)) ->
(EqRat (AddRationals x a y b) (productNonZero a b) (AddRationals y b x a) (productNonZero b a))
plusCommQEqRat x a y b = eqMeansEqRat (AddRationals x a y b) (productNonZero a b) (AddRationals y b x a) (productNonZero b a) (plusCommutativeQ x a y b)

|||Constructs an equality between (a,b)*(c,d) and (c,d)*(a,b)
multCommQEqRat: (x: ZZPair) -> (a: NotZero (snd x)) -> (y: ZZPair) -> (b: NotZero (snd y)) ->
(EqRat (MultiplyRationals x a y b) (productNonZero a b) (MultiplyRationals y b x a) (productNonZero b a))
multCommQEqRat x a y b = eqMeansEqRat (MultiplyRationals x a y b) (productNonZero a b) (MultiplyRationals y b x a) (productNonZero b a) (multCommutativeQ x a y b)

|||Constructs an equality between (a,b) + (0,1) and (a,b).
addIdRightEqRat: (x: ZZPair) -> (a: NotZero (snd x)) ->
(EqRat (AddRationals x a (0,1) PositiveZ) (productNonZero a (PositiveZ)) x a)
addIdRightEqRat x a = eqMeansEqRat (AddRationals x a (0,1) PositiveZ) (productNonZero a (PositiveZ)) (x) (a) (zeroAddIdentityRight x a)

|||Constructs an equality between (a,b) and (a,b) + (0,1).
addIdLeftEqRat: (x: ZZPair) -> (a: NotZero (snd x)) ->
(EqRat (AddRationals (0,1) PositiveZ x a) (productNonZero (PositiveZ) a) x a)
addIdLeftEqRat x a = eqMeansEqRat (AddRationals (0,1) PositiveZ x a) (productNonZero (PositiveZ) a) (x) (a) (zeroAddIdentityLeft x a)

|||Constructs an equality between (a,b)*(1,1) and (a,b).
multIdRightEqRat: (x: ZZPair) -> (a: NotZero (snd x)) ->
(EqRat (MultiplyRationals x a (1,1) PositiveZ) (productNonZero a (PositiveZ)) x a)
multIdRightEqRat x a = eqMeansEqRat (MultiplyRationals x a (1,1) PositiveZ) (productNonZero a (PositiveZ)) (x) (a) (oneMultIdentityRight x a)

|||Constructs an equality between (a,b)*(1,1) and (a,b).
multIdLeftEqRat: (x: ZZPair) -> (a: NotZero (snd x)) ->
(EqRat (MultiplyRationals (1,1) PositiveZ x a) (productNonZero (PositiveZ) a) x a)
multIdLeftEqRat x a = eqMeansEqRat (MultiplyRationals (1,1) PositiveZ x a) (productNonZero (PositiveZ) a) (x) (a) (oneMultIdentityLeft x a)

|||Constructs an equality between ((a,b)+(-a,b)) and 0.
addInverseLeftEqRat: (x: ZZPair) -> (a: NotZero (snd x)) ->
(EqRat (AddRationals x a (AddInverse x a) (xAndInverseNotZeroPlus x a) ) (productNonZero a (xAndInverseNotZeroPlus x a)) (0,1) PositiveZ)
addInverseLeftEqRat x a = EqRatTrans (AddRationals x a (AddInverse x a) (xAndInverseNotZeroPlus x a)) (productNonZero a (xAndInverseNotZeroPlus x a)) ((Pos 0), (snd x)*(snd x)) (productNonZero a a) (0,1) (PositiveZ) (EqRatAddInvLeft x a) (reducedFormZeroRight ((snd x)*(snd x)) (productNonZero a a))

|||Constructs an equality between 0 and ((a,b)+(-a,b)).
addInverseRightEqRat: (x: ZZPair) -> (a: NotZero (snd x)) ->
(EqRat (AddRationals (AddInverse x a) (xAndInverseNotZeroPlus x a) x a) (productNonZero a (xAndInverseNotZeroPlus x a)) (0,1) PositiveZ)
addInverseRightEqRat x a = EqRatTrans (AddRationals (AddInverse x a) (xAndInverseNotZeroPlus x a) x a) (productNonZero a (xAndInverseNotZeroPlus x a)) ((Pos 0), (snd x)*(snd x)) (productNonZero a a) (0,1) (PositiveZ) (EqRatAddInvRight x a) (reducedFormZeroRight ((snd x)*(snd x)) (productNonZero a a))

|||Constructs an equality between (a,b)*(b,a) and (1,1).
multInverseLeftEqRat: (x: ZZPair) -> (a: NotZero (fst x)) -> (b: NotZero (snd x)) ->
(EqRat (MultiplyRationals x b (MultInverse x a b) (xAndInverseNotZeroMult x a b)) (productNonZero b (xAndInverseNotZeroMult x a b)) (1,1) (PositiveZ))
multInverseLeftEqRat x a b = EqRatTrans (MultiplyRationals x b (MultInverse x a b) (xAndInverseNotZeroMult x a b)) (productNonZero b (xAndInverseNotZeroMult x a b)) ((fst x)*(snd x), (fst x)*(snd x)) (productNonZero a b) (1,1) (PositiveZ) (EqRatMultInvLeft x a b) (reducedFormOneRight ((fst x)*(snd x)) (productNonZero a b))

|||Constructs an equality between (1,1) and (a,b)*(b,a).
multInverseRightEqRat: (x: ZZPair) -> (a: NotZero (fst x)) -> (b: NotZero (snd x)) ->
(EqRat (MultiplyRationals (MultInverse x a b) (xAndInverseNotZeroMult x a b) x b) (productNonZero (xAndInverseNotZeroMult x a b) b) (1,1) (PositiveZ))
multInverseRightEqRat x a b = EqRatTrans (MultiplyRationals (MultInverse x a b) (xAndInverseNotZeroMult x a b) x b) (productNonZero (xAndInverseNotZeroMult x a b) b) ((snd x)*(fst x), (snd x)*(fst x)) (productNonZero b a) (1,1) (PositiveZ) (EqRatMultInvRight x a b) (reducedFormOneRight ((snd x)*(fst x)) (productNonZero b a))

|||Constructs an EqRat element of associativity for addition.
plusAssocQEqRat: (x: ZZPair) -> (a: NotZero (snd x)) -> (y: ZZPair) -> (b: NotZero (snd y)) -> (z: ZZPair) -> (c: NotZero (snd z)) ->
(EqRat (AddRationals (AddRationals x a y b) (productNonZero a b) z c) (productNonZero (productNonZero a b) c) (AddRationals x a (AddRationals y b z c) (productNonZero b c)) (productNonZero a (productNonZero b c)))
plusAssocQEqRat x a y b z c = eqMeansEqRat (AddRationals (AddRationals x a y b) (productNonZero a b) z c) (productNonZero (productNonZero a b) c) (AddRationals x a (AddRationals y b z c) (productNonZero b c)) (productNonZero a (productNonZero b c)) (plusAssociativeQ x a y b z c)

|||Constructs an EqRat element of associativity for multiplication.
multAssocQEqRat: (x: ZZPair) -> (a: NotZero (snd x)) -> (y: ZZPair) -> (b: NotZero (snd y)) -> (z: ZZPair) -> (c: NotZero (snd z)) ->
(EqRat (MultiplyRationals (MultiplyRationals x a y b) (productNonZero a b) z c) (productNonZero (productNonZero a b) c) (MultiplyRationals x a (MultiplyRationals y b z c) (productNonZero b c)) (productNonZero a (productNonZero b c)))
multAssocQEqRat x a y b z c = eqMeansEqRat (MultiplyRationals (MultiplyRationals x a y b) (productNonZero a b) z c) (productNonZero (productNonZero a b) c) (MultiplyRationals x a (MultiplyRationals y b z c) (productNonZero b c)) (productNonZero a (productNonZero b c)) (multAssociativeQ x a y b z c)


module PatternMatching

zahlen : List Nat
zahlen = [1,2,3,4,5]

person : (String, Nat)
person = ("Max", 40)

data Farbe
  = Rot
  | Blau

data Expression : Type -> Type where
  Falsch : Expression Bool
  Wahr : Expression Bool
  Zahl : Nat -> Expression Nat
  Plus : Expression Nat -> Expression Nat -> Expression Nat
  Gleich : Expression Nat -> Expression Nat -> Expression Bool
  Falls : Expression Bool -> Expression a -> Expression a -> Expression a

istLeer : List a -> Bool
istLeer [] = True
istLeer (x :: xs) = False

name : (String, Nat) -> String
name (n, _) = n

eval : Expression a -> a
eval Falsch = False
eval Wahr = True
eval (Zahl k) = k
eval (Plus x y) = eval x + eval y
eval (Gleich x y) = eval x == eval y
eval (Falls b t e) = if (eval b) then eval t else eval e


module Verified.Functor

%default total

class Functor f => VerifiedFunctor (f : Type -> Type) where
  functorIdentity : {a : Type} -> (x : f a) -> map id x = id x
  functorComposition : {a : Type} -> {b : Type} -> (x : f a) ->
                   (g1 : a -> b) -> (g2 : b -> c) ->
                   map (g2 . g1) x = (map g2 . map g1) x


module Vec

import Data.Fin

%default total

%logging 1
%logging declare.def 2

Vec : Type -> Nat -> Type
Vec a n = Fin n -> a

Nil : Vec a Z
Nil = absurd

(::) : a -> Vec a n -> Vec a (S n)
(x :: xs) FZ = x
(x :: xs) (FS i) = xs i

test : Vec (List Nat) 2
test = [[], [0]]