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 Data.Vect

import Data.DPair
import Data.List
import Data.Nat
import public Data.Fin
import public Data.Zippable

import Decidable.Equality

%default total

public export
data Vect : (len : Nat) -> (elem : Type) -> Type where
  ||| Empty vector
  Nil  : Vect Z elem
  ||| A non-empty vector of length `S len`, consisting of a head element and
  ||| the rest of the list, of length `len`.
  (::) : (x : elem) -> (xs : Vect len elem) -> Vect (S len) elem

-- Hints for interactive editing
%name Vect xs, ys, zs, ws

public export
length : (xs : Vect len elem) -> Nat
length [] = 0
length (_::xs) = 1 + length xs

||| Show that the length function on vectors in fact calculates the length
export
lengthCorrect : (xs : Vect len elem) -> length xs = len
lengthCorrect []        = Refl
lengthCorrect (_ :: xs) = rewrite lengthCorrect xs in Refl

||| If two vectors are equal, their heads and tails are equal
export
vectInjective : {0 xs : Vect n a} -> {0 ys : Vect m b} -> x::xs = y::ys -> (x = y, xs = ys)
vectInjective Refl = (Refl, Refl)

--------------------------------------------------------------------------------
-- Indexing into vectors
--------------------------------------------------------------------------------

||| All but the first element of the vector
|||
||| ```idris example
||| tail [1,2,3,4]
||| ```
public export
tail : Vect (S len) elem -> Vect len elem
tail (_::xs) = xs

||| Only the first element of the vector
|||
||| ```idris example
||| head [1,2,3,4]
||| ```
public export
head : Vect (S len) elem -> elem
head (x::_) = x

||| The last element of the vector
|||
||| ```idris example
||| last [1,2,3,4]
||| ```
public export
last : Vect (S len) elem -> elem
last [x]        = x
last (_::y::ys) = last $ y::ys

||| All but the last element of the vector
|||
||| ```idris example
||| init [1,2,3,4]
||| ```
public export
init : Vect (S len) elem -> Vect len elem
init [_]        = []
init (x::y::ys) = x :: init (y::ys)

||| Extract the first `n` elements of a Vect.
public export
take : (n  : Nat)
    -> (  xs : Vect (n + m) type)
    -> Vect n type
take 0 xs = Nil
take (S k) (x :: xs) = x :: take k xs

namespace Stream
  ||| Take precisely n elements from the stream.
  ||| @ n how many elements to take
  ||| @ xs the stream
  public export
  take : (n : Nat) -> (xs : Stream a) -> Vect n a
  take Z xs = []
  take (S k) (x :: xs) = x :: take k xs

||| Drop the first `n` elements of a Vect.
public export
drop : (n : Nat) -> Vect (n + m) elem -> Vect m elem
drop 0 xs = xs
drop (S k) (x :: xs) = drop k xs

||| Drop up to the first `n` elements of a Vect.
public export
drop' : (n : Nat) -> Vect l elem -> Vect (l `minus` n) elem
drop' 0 xs = rewrite minusZeroRight l in xs
drop' (S k) [] = rewrite minusZeroLeft (S k) in []
drop' (S k) (x :: xs) = drop' k xs

||| Extract a particular element from a vector
|||
||| ```idris example
||| index 1 [1,2,3,4]
||| ```
public export
index : Fin len -> Vect len elem -> elem
index FZ     (x::_)  = x
index (FS k) (_::xs) = index k xs

||| Insert an element at a particular index
|||
||| ```idris example
||| insertAt 1 8 [1,2,3,4]
||| ```
public export
insertAt : (idx : Fin (S len)) -> (x : elem) -> (xs : Vect len elem) -> Vect (S len) elem
insertAt FZ     y xs      = y :: xs
insertAt (FS k) y (x::xs) = x :: insertAt k y xs

||| Construct a new vector consisting of all but the indicated element
|||
||| ```idris example
||| deleteAt 1 [1,2,3,4]
||| ```
public export
deleteAt : Fin (S len) -> Vect (S len) elem -> Vect len elem
deleteAt FZ     (_::xs)        = xs
deleteAt (FS k) [x]            = absurd k
deleteAt (FS k) (x::xs@(_::_)) = x :: deleteAt k xs

||| Replace an element at a particlar index with another
|||
||| ```idris example
||| replaceAt 1 8 [1,2,3,4]
||| ```
public export
replaceAt : Fin len -> elem -> Vect len elem -> Vect len elem
replaceAt FZ     y (_::xs) = y :: xs
replaceAt (FS k) y (x::xs) = x :: replaceAt k y xs

||| Replace the element at a particular index with the result of applying a function to it
||| @ i the index to replace at
||| @ f the update function
||| @ xs the vector to replace in
|||
||| ```idris example
||| updateAt 1 (+10) [1,2,3,4]
||| ```
public export
updateAt : (i : Fin len) -> (f : elem -> elem) -> (xs : Vect len elem) -> Vect len elem
updateAt FZ     f (x::xs) = f x :: xs
updateAt (FS k) f (x::xs) = x :: updateAt k f xs

||| Append two vectors
|||
||| ```idris example
||| [1,2,3,4] ++ [5,6]
||| ```
public export
(++) : (xs : Vect m elem) -> (ys : Vect n elem) -> Vect (m + n) elem
(++) []      ys = ys
(++) (x::xs) ys = x :: xs ++ ys

||| Add an element at the end of the vector.
||| The main use case for it is to get the expected type signature
||| `Vect n a -> a -> Vect (S n) a` instead of
||| `Vect n a -> a -> Vect (n + 1) a` which you get by using `++ [x]`
|||
||| Snoc gets its name by reversing `cons`, indicating we are
||| tacking on the element at the end rather than the begining.
||| `append` would also be a suitable name.
|||
||| @ xs The vector to be appended
||| @ v The value to append
public export
snoc : (xs : Vect n a) -> (v : a) -> Vect (S n) a
snoc [] v = [v]
snoc (x :: xs) v = x :: snoc xs v

||| Repeate some value some number of times.
|||
||| @ len the number of times to repeat it
||| @ x the value to repeat
|||
||| ```idris example
||| replicate 4 1
||| ```
public export
replicate : (len : Nat) -> (x : elem) -> Vect len elem
replicate Z     _ = []
replicate (S k) x = x :: replicate k x

||| Merge two ordered vectors
|||
||| ```idris example
||| mergeBy compare (fromList [1,3,5]) (fromList [2,3,4,5,6])
||| ```
export
mergeBy : (elem -> elem -> Ordering) -> (xs : Vect n elem) -> (ys : Vect m elem) -> Vect (n + m) elem
mergeBy _ [] ys = ys
mergeBy _ xs [] = rewrite plusZeroRightNeutral n in xs
mergeBy {n = S k} {m = S k'} order (x :: xs) (y :: ys)
     = case order x y of
            LT => x :: mergeBy order xs (y :: ys)
            _  => rewrite sym (plusSuccRightSucc k k') in
                             y :: mergeBy order (x :: xs) ys

export
merge : Ord elem => Vect n elem -> Vect m elem -> Vect (n + m) elem
merge = mergeBy compare

-- Properties for functions in this section --

export
replaceAtSameIndex : (xs : Vect n a) -> (i : Fin n) -> (0 y : a) -> index i (replaceAt i y xs) = y
replaceAtSameIndex (_::_) FZ     _ = Refl
replaceAtSameIndex (_::_) (FS _) _ = replaceAtSameIndex _ _ _

export
replaceAtDiffIndexPreserves : (xs : Vect n a) -> (i, j : Fin n) -> Not (i = j) -> (0 y : a) -> index i (replaceAt j y xs) = index i xs
replaceAtDiffIndexPreserves (_::_) FZ     FZ     co _ = absurd $ co Refl
replaceAtDiffIndexPreserves (_::_) FZ     (FS _) _  _ = Refl
replaceAtDiffIndexPreserves (_::_) (FS _) FZ     _  _ = Refl
replaceAtDiffIndexPreserves (_::_) (FS z) (FS w) co y = replaceAtDiffIndexPreserves _ z w (co . cong FS) y

--------------------------------------------------------------------------------
-- Transformations
--------------------------------------------------------------------------------

||| Reverse the order of the elements of a vector
|||
||| ```idris example
||| reverse [1,2,3,4]
||| ```
public export
reverse : (xs : Vect len elem) -> Vect len elem
reverse xs = go [] xs
  where go : Vect n elem -> Vect m elem -> Vect (n+m) elem
        go {n}         acc []        = rewrite plusZeroRightNeutral n in acc
        go {n} {m=S m} acc (x :: xs) = rewrite sym $ plusSuccRightSucc n m
                                       in go (x::acc) xs

||| Alternate an element between the other elements of a vector
||| @ sep the element to intersperse
||| @ xs the vector to separate with `sep`
|||
||| ```idris example
||| intersperse 0 [1,2,3,4]
||| ```
export
intersperse : (sep : elem) -> (xs : Vect len elem) -> Vect (len + pred len) elem
intersperse sep []      = []
intersperse sep (x::xs) = x :: intersperse' sep xs
  where
    intersperse' : elem -> Vect n elem -> Vect (n + n) elem
    intersperse'         sep []      = []
    intersperse' {n=S n} sep (x::xs) = rewrite sym $ plusSuccRightSucc n n
                                       in sep :: x :: intersperse' sep xs

--------------------------------------------------------------------------------
-- Conversion from list (toList is provided by Foldable)
--------------------------------------------------------------------------------

public export
toVect : (n : Nat) -> List a -> Maybe (Vect n a)
toVect Z [] = Just []
toVect (S k) (x :: xs)
    = do xs' <- toVect k xs
         pure (x :: xs')
toVect _ _ = Nothing

public export
fromList' : (xs : Vect len elem) -> (l : List elem) -> Vect (length l + len) elem
fromList' ys [] = ys
fromList' ys (x::xs) =
  rewrite (plusSuccRightSucc (length xs) len) in
  fromList' (x::ys) xs

||| Convert a list to a vector.
|||
||| The length of the list should be statically known.
|||
||| ```idris example
||| fromList [1,2,3,4]
||| ```
public export
fromList : (xs : List elem) -> Vect (length xs) elem
fromList l =
  rewrite (sym $ plusZeroRightNeutral (length l)) in
  reverse $ fromList' [] l

--------------------------------------------------------------------------------
-- Equality
--------------------------------------------------------------------------------

public export
Eq a => Eq (Vect n a) where
  (==) []      []      = True
  (==) (x::xs) (y::ys) = x == y && xs == ys

public export
DecEq a => DecEq (Vect n a) where
  decEq []      []      = Yes Refl
  decEq (x::xs) (y::ys) with (decEq x y, decEq xs ys)
    decEq (x::xs) (x::xs) | (Yes Refl, Yes Refl) = Yes Refl
    decEq (x::xs) (y::ys) | (No nhd, _) = No $ nhd . fst . vectInjective
    decEq (x::xs) (y::ys) | (_, No ntl) = No $ ntl . snd . vectInjective

--------------------------------------------------------------------------------
-- Order
--------------------------------------------------------------------------------

public export
implementation Ord elem => Ord (Vect len elem) where
  compare []      []      = EQ
  compare (x::xs) (y::ys)
      = case compare x y of
             EQ => compare xs ys
             x => x

--------------------------------------------------------------------------------
-- Maps
--------------------------------------------------------------------------------

public export
implementation Functor (Vect n) where
  map f []        = []
  map f (x::xs) = f x :: map f xs

||| Map a partial function across a vector, returning those elements for which
||| the function had a value.
|||
||| The first projection of the resulting pair (ie the length) will always be
||| at most the length of the input vector. This is not, however, guaranteed
||| by the type.
|||
||| @ f the partial function (expressed by returning `Maybe`)
||| @ xs the vector to check for results
|||
||| ```idris example
||| mapMaybe ((find (=='a')) . unpack) (fromList ["abc","ade","bgh","xyz"])
||| ```
export
mapMaybe : (f : a -> Maybe b) -> (xs : Vect len a) -> (m : Nat ** Vect m b)
mapMaybe f []      = (_ ** [])
mapMaybe f (x::xs) =
  let (len ** ys) = mapMaybe f xs
  in case f x of
       Just y  => (S len ** y :: ys)
       Nothing => (  len **      ys)

--------------------------------------------------------------------------------
-- Folds
--------------------------------------------------------------------------------

public export
foldrImpl : (t -> acc -> acc) -> acc -> (acc -> acc) -> Vect n t -> acc
foldrImpl f e go [] = go e
foldrImpl f e go (x::xs) = foldrImpl f e (go . (f x)) xs

public export
implementation Foldable (Vect n) where
  foldr f e xs = foldrImpl f e id xs
  foldl f z [] = z
  foldl f z (x :: xs) = foldl f (f z x) xs

  null [] = True
  null _ = False

  foldMap f = foldl (\acc, elem => acc <+> f elem) neutral

--------------------------------------------------------------------------------
-- Special folds
--------------------------------------------------------------------------------

||| Flatten a vector of equal-length vectors
|||
||| ```idris example
||| concat [[1,2,3], [4,5,6]]
||| ```
public export
concat : (xss : Vect m (Vect n elem)) -> Vect (m * n) elem
concat []      = []
concat (v::vs) = v ++ Vect.concat vs

||| Foldr without seeding the accumulator
|||
||| ```idris example
||| foldr1 (-) (fromList [1,2,3])
||| ```
public export
foldr1 : (t -> t -> t) -> Vect (S n) t -> t
foldr1 f [x]        = x
foldr1 f (x::y::xs) = f x (foldr1 f (y::xs))

||| Foldl without seeding the accumulator
|||
||| ```idris example
||| foldl1 (-) (fromList [1,2,3])
||| ```
public export
foldl1 : (t -> t -> t) -> Vect (S n) t -> t
foldl1 f (x::xs) = foldl f x xs
--------------------------------------------------------------------------------
-- Scans
--------------------------------------------------------------------------------

||| The scanl function is similar to foldl, but returns all the intermediate
||| accumulator states in the form of a vector.
|||
||| ```idris example
||| scanl (-) 0 (fromList [1,2,3])
||| ```
public export
scanl : (res -> elem -> res) -> res -> Vect len elem -> Vect (S len) res
scanl f q []      = [q]
scanl f q (x::xs) = q :: scanl f (f q x) xs

||| The scanl1 function is a variant of scanl that doesn't require an explicit
||| starting value.
||| It assumes the first element of the vector to be the starting value and then
||| starts the fold with the element following it.
|||
||| ```idris example
||| scanl1 (-) (fromList [1,2,3])
||| ```
public export
scanl1 : (elem -> elem -> elem) -> Vect len elem -> Vect len elem
scanl1 f [] = []
scanl1 f (x::xs) = scanl f x xs

--------------------------------------------------------------------------------
-- Membership tests
--------------------------------------------------------------------------------

||| Search for an item using a user-provided test
||| @ p the equality test
||| @ e the item to search for
||| @ xs the vector to search in
|||
||| ```idris example
||| elemBy (==) 2 [1,2,3,4]
||| ```
public export
elemBy : (p : elem -> elem -> Bool) -> (e : elem) -> (xs : Vect len elem) -> Bool
elemBy p e []      = False
elemBy p e (x::xs) = p e x || elemBy p e xs

||| Use the default Boolean equality on elements to search for an item
||| @ x what to search for
||| @ xs where to search
|||
||| ```idris example
||| elem 3 [1,2,3,4]
||| ```
public export
elem : Eq elem => (x : elem) -> (xs : Vect len elem) -> Bool
elem = elemBy (==)

||| Find the association of some key with a user-provided comparison
||| @ p the comparison operator for keys (True if they match)
||| @ e the key to look for
|||
||| ```idris example
||| lookupBy (==) 2 [(1, 'a'), (2, 'b'), (3, 'c')]
||| ```
public export
lookupBy : (p : key -> key -> Bool) -> (e : key) -> (xs : Vect n (key, val)) -> Maybe val
lookupBy p e []           = Nothing
lookupBy p e ((l, r)::xs) = if p e l then Just r else lookupBy p e xs

||| Find the assocation of some key using the default Boolean equality test
|||
||| ```idris example
||| lookup 3 [(1, 'a'), (2, 'b'), (3, 'c')]
||| ```
public export
lookup : Eq key => key -> Vect n (key, val) -> Maybe val
lookup = lookupBy (==)

||| Check if any element of xs is found in elems by a user-provided comparison
||| @ p the comparison operator
||| @ elems the vector to search
||| @ xs what to search for
|||
||| ```idris example
||| hasAnyBy (==) [2,5] [1,2,3,4]
||| ```
public export
hasAnyBy : (p : elem -> elem -> Bool) -> (elems : Vect m elem) -> (xs : Vect len elem) -> Bool
hasAnyBy p elems []      = False
hasAnyBy p elems (x::xs) = elemBy p x elems || hasAnyBy p elems xs

||| Check if any element of xs is found in elems using the default Boolean equality test
|||
||| ```idris example
||| hasAny [2,5] [1,2,3,4]
||| ```
public export
hasAny : Eq elem => Vect m elem -> Vect len elem -> Bool
hasAny = hasAnyBy (==)

--------------------------------------------------------------------------------
-- Searching with a predicate
--------------------------------------------------------------------------------

||| Find the first element of the vector that satisfies some test
||| @ p the test to satisfy
|||
||| ```idris example
||| find (== 3) [1,2,3,4]
||| ```
public export
find : (p : elem -> Bool) -> (xs : Vect len elem) -> Maybe elem
find p []      = Nothing
find p (x::xs) = if p x then Just x else find p xs

||| Find the index of the first element of the vector that satisfies some test
|||
||| ```idris example
||| findIndex (== 3) [1,2,3,4]
||| ```
public export
findIndex : (elem -> Bool) -> Vect len elem -> Maybe (Fin len)
findIndex p []        = Nothing
findIndex p (x :: xs) = if p x then Just FZ else FS <$> findIndex p xs

||| Find the indices of all elements that satisfy some test
|||
||| ```idris example
||| findIndices (< 3) [1,2,3,4]
||| ```
public export
findIndices : (elem -> Bool) -> Vect m elem -> List (Fin m)
findIndices p []        = []
findIndices p (x :: xs)
     = let is = FS <$> findIndices p xs in
           if p x then FZ :: is else is

||| Find the index of the first element of the vector that satisfies some test
|||
||| ```idris example
||| elemIndexBy (==) 3 [1,2,3,4]
||| ```
public export
elemIndexBy : (elem -> elem -> Bool) -> elem -> Vect m elem -> Maybe (Fin m)
elemIndexBy p e = findIndex $ p e

||| Find the index of the first element of the vector equal to the given one.
|||
||| ```idris example
||| elemIndex 3 [1,2,3,4]
||| ```
public export
elemIndex : Eq elem => elem -> Vect m elem -> Maybe (Fin m)
elemIndex = elemIndexBy (==)

||| Find the indices of all elements that satisfy some test
|||
||| ```idris example
||| elemIndicesBy (<=) 3 [1,2,3,4]
||| ```
public export
elemIndicesBy : (elem -> elem -> Bool) -> elem -> Vect m elem -> List (Fin m)
elemIndicesBy p e = findIndices $ p e

||| Find the indices of all elements uquals to the given one
|||
||| ```idris example
||| elemIndices 3 [1,2,3,4,3]
||| ```
public export
elemIndices : Eq elem => elem -> Vect m elem -> List (Fin m)
elemIndices = elemIndicesBy (==)

--------------------------------------------------------------------------------
-- Filters
--------------------------------------------------------------------------------

||| Find all elements of a vector that satisfy some test
|||
||| ```idris example
||| filter (< 3) (fromList [1,2,3,4])
||| ```
public export
filter : (elem -> Bool) -> Vect len elem -> (p ** Vect p elem)
filter p []      = ( _ ** [] )
filter p (x::xs) =
  let (_ ** tail) = filter p xs
   in if p x then
        (_ ** x::tail)
      else
        (_ ** tail)

||| Make the elements of some vector unique by some test
|||
||| ```idris example
||| nubBy (==) (fromList [1,2,2,3,4,4])
||| ```
public export
nubBy : (elem -> elem -> Bool) -> Vect len elem -> (p ** Vect p elem)
nubBy = nubBy' []
  where
    nubBy' : forall len . Vect m elem -> (elem -> elem -> Bool) -> Vect len elem -> (p ** Vect p elem)
    nubBy' acc p []      = (_ ** [])
    nubBy' acc p (x::xs) with (elemBy p x acc)
      nubBy' acc p (x :: xs) | True  = nubBy' acc p xs
      nubBy' acc p (x :: xs) | False with (nubBy' (x::acc) p xs)
        nubBy' acc p (x :: xs) | False | (_ ** tail) = (_ ** x::tail)

||| Make the elements of some vector unique by the default Boolean equality
|||
||| ```idris example
||| nub (fromList [1,2,2,3,4,4])
||| ```
public export
nub : Eq elem => Vect len elem -> (p ** Vect p elem)
nub = nubBy (==)

||| Delete first element from list according to some test
|||
||| ```idris example
||| deleteBy (<) 3 (fromList [1,2,2,3,4,4])
||| ```
public export
deleteBy : {len : _} -> -- needed for the dependent pair
           (elem -> elem -> Bool) -> elem -> Vect len elem -> (p ** Vect p elem)
deleteBy _  _ []      = (_ ** [])
deleteBy eq x (y::ys) =
  let (len ** zs) = deleteBy eq x ys
  in if x `eq` y then (_ ** ys) else (S len ** y ::zs)

||| Delete first element from list equal to the given one
|||
||| ```idris example
||| delete 2 (fromList [1,2,2,3,4,4])
||| ```
public export
delete : {len : _} ->
         Eq elem => elem -> Vect len elem -> (p ** Vect p elem)
delete = deleteBy (==)

--------------------------------------------------------------------------------
-- Splitting and breaking lists
--------------------------------------------------------------------------------

||| A tuple where the first element is a `Vect` of the `n` first elements and
||| the second element is a `Vect` of the remaining elements of the original.
||| It is equivalent to `(take n xs, drop n xs)` (`splitAtTakeDrop`),
||| but is more efficient.
|||
||| @ n   the index to split at
||| @ xs  the `Vect` to split in two
|||
||| ```idris example
||| splitAt 2 (fromList [1,2,3,4])
||| ```
public export
splitAt : (n : Nat) -> (xs : Vect (n + m) elem) -> (Vect n elem, Vect m elem)
splitAt Z xs = ([], xs)
splitAt (S k) (x :: xs) with (splitAt k {m} xs)
  splitAt (S k) (x :: xs) | (tk, dr) = (x :: tk, dr)

||| A tuple where the first element is a `Vect` of the `n` elements passing given test
||| and the second element is a `Vect` of the remaining elements of the original.
|||
||| ```idris example
||| partition (== 2) (fromList [1,2,3,2,4])
||| ```
public export
partition : (elem -> Bool) -> Vect len elem -> ((p ** Vect p elem), (q ** Vect q elem))
partition p []      = ((_ ** []), (_ ** []))
partition p (x::xs) =
  let ((leftLen ** lefts), (rightLen ** rights)) = partition p xs in
    if p x then
      ((S leftLen ** x::lefts), (rightLen ** rights))
    else
      ((leftLen ** lefts), (S rightLen ** x::rights))

--------------------------------------------------------------------------------
-- Predicates
--------------------------------------------------------------------------------

||| Verify vector prefix
|||
||| ```idris example
||| isPrefixOfBy (==) (fromList [1,2]) (fromList [1,2,3,4])
||| ```
public export
isPrefixOfBy : (elem -> elem -> Bool) -> Vect m elem -> Vect len elem -> Bool
isPrefixOfBy p [] right        = True
isPrefixOfBy p left []         = False
isPrefixOfBy p (x::xs) (y::ys) = p x y && isPrefixOfBy p xs ys

||| Verify vector prefix
|||
||| ```idris example
||| isPrefixOf (fromList [1,2]) (fromList [1,2,3,4])
||| ```
public export
isPrefixOf : Eq elem => Vect m elem -> Vect len elem -> Bool
isPrefixOf = isPrefixOfBy (==)

||| Verify vector suffix
|||
||| ```idris example
||| isSuffixOfBy (==) (fromList [3,4]) (fromList [1,2,3,4])
||| ```
public export
isSuffixOfBy : (elem -> elem -> Bool) -> Vect m elem -> Vect len elem -> Bool
isSuffixOfBy p left right = isPrefixOfBy p (reverse left) (reverse right)

||| Verify vector suffix
|||
||| ```idris example
||| isSuffixOf (fromList [3,4]) (fromList [1,2,3,4])
||| ```
public export
isSuffixOf : Eq elem => Vect m elem -> Vect len elem -> Bool
isSuffixOf = isSuffixOfBy (==)

--------------------------------------------------------------------------------
-- Conversions
--------------------------------------------------------------------------------

||| Convert Maybe type into Vect
|||
||| ```idris example
||| maybeToVect (Just 2)
||| ```
public export
maybeToVect : Maybe elem -> (p ** Vect p elem)
maybeToVect Nothing  = (_ ** [])
maybeToVect (Just j) = (_ ** [j])

||| Convert first element of Vect (if exists) into Maybe.
|||
||| ```idris example
||| vectToMaybe [2]
||| ```
public export
vectToMaybe : Vect len elem -> Maybe elem
vectToMaybe []      = Nothing
vectToMaybe (x::xs) = Just x

--------------------------------------------------------------------------------
-- Misc
--------------------------------------------------------------------------------

||| Filter out Nothings from Vect and unwrap the Justs
|||
||| ```idris example
||| catMaybes [Just 1, Just 2, Nothing, Nothing, Just 5]
||| ```
public export
catMaybes : (xs : Vect n (Maybe elem)) -> (p ** Vect p elem)
catMaybes []             = (_ ** [])
catMaybes (Nothing::xs)  = catMaybes xs
catMaybes ((Just j)::xs) =
  let (_ ** tail) = catMaybes xs
   in (_ ** j::tail)

||| Get diagonal elements
|||
||| ```idris example
||| diag [[1,2,3], [4,5,6], [7,8,9]]
||| ```
public export
diag : Vect len (Vect len elem) -> Vect len elem
diag []             = []
diag ((x::xs)::xss) = x :: diag (map tail xss)

namespace Fin

  public export
  tabulate : {len : Nat} -> (Fin len -> a) -> Vect len a
  tabulate {len = Z} f = []
  tabulate {len = S _} f = f FZ :: tabulate (f . FS)

  public export
  range : {len : Nat} -> Vect len (Fin len)
  range = tabulate id

namespace Subset

  public export
  tabulate : {len : Nat} -> (Subset Nat (`LT` len) -> a) -> Vect len a
  tabulate {len = Z} f = []
  tabulate {len = S _} f
    = f (Element Z ltZero)
    :: Subset.tabulate (\ (Element n prf) => f (Element (S n) (LTESucc prf)))

  public export
  range : {len : Nat} -> Vect len (Subset Nat (`LT` len))
  range = tabulate id

--------------------------------------------------------------------------------
-- Zippable
--------------------------------------------------------------------------------

public export
Zippable (Vect k) where
  zipWith _ [] [] = []
  zipWith f (x :: xs) (y :: ys) = f x y :: zipWith f xs ys

  zipWith3 _ [] [] [] = []
  zipWith3 f (x :: xs) (y :: ys) (z :: zs) = f x y z :: zipWith3 f xs ys zs

  unzipWith f [] = ([], [])
  unzipWith f (x :: xs) = let (b, c) = f x
                              (bs, cs) = unzipWith f xs in
                              (b :: bs, c :: cs)

  unzipWith3 f [] = ([], [], [])
  unzipWith3 f (x :: xs) = let (b, c, d) = f x
                               (bs, cs, ds) = unzipWith3 f xs in
                               (b :: bs, c :: cs, d :: ds)

export
zipWithIndexLinear : (0 f : _) -> (xs, ys : Vect n a) -> (i : Fin n) -> index i (zipWith f xs ys) = f (index i xs) (index i ys)
zipWithIndexLinear _ (_::xs) (_::ys) FZ     = Refl
zipWithIndexLinear f (_::xs) (_::ys) (FS i) = zipWithIndexLinear f xs ys i

export
zipWith3IndexLinear : (0 f : _) -> (xs, ys, zs : Vect n a) -> (i : Fin n) -> index i (zipWith3 f xs ys zs) = f (index i xs) (index i ys) (index i zs)
zipWith3IndexLinear _ (_::xs) (_::ys) (_::zs) FZ     = Refl
zipWith3IndexLinear f (_::xs) (_::ys) (_::zs) (FS i) = zipWith3IndexLinear f xs ys zs i

--------------------------------------------------------------------------------
-- Matrix transposition
--------------------------------------------------------------------------------
||| Transpose a `Vect` of `Vect`s, turning rows into columns and vice versa.
|||
||| This is like zipping all the inner `Vect`s together and is equivalent to `traverse id` (`transposeTraverse`).
|||
||| As the types ensure rectangularity, this is an involution, unlike `Prelude.List.transpose`.
|||
||| ```idris example
||| transpose [[1,2], [3,4], [5,6], [7,8]]
||| ```
public export
transpose : {n : _} -> (array : Vect m (Vect n elem)) -> Vect n (Vect m elem)
transpose []        = replicate _ []                 -- = [| [] |]
transpose (x :: xs) = zipWith (::) x (transpose xs) -- = [| x :: xs |]

--------------------------------------------------------------------------------
-- Applicative/Monad/Traversable
--------------------------------------------------------------------------------
-- These only work if the length is known at run time!

public export
implementation {k : Nat} -> Applicative (Vect k) where
    pure = replicate _
    fs <*> vs = zipWith apply fs vs

-- ||| This monad is different from the List monad, (>>=)
-- ||| uses the diagonal.
public export
implementation {k : Nat} -> Monad (Vect k) where
    m >>= f = diag (map f m)

public export
implementation Traversable (Vect k) where
    traverse f []        = pure []
    traverse f (x :: xs) = [| f x :: traverse f xs |]

--------------------------------------------------------------------------------
-- Semigroup/Monoid
--------------------------------------------------------------------------------

public export
Semigroup a => Semigroup (Vect k a) where
  (<+>) = zipWith (<+>)

public export
{k : Nat} -> Monoid a => Monoid (Vect k a) where
  neutral = replicate k neutral

--------------------------------------------------------------------------------
-- Show
--------------------------------------------------------------------------------

export
implementation Show elem => Show (Vect len elem) where
    show = show . toList

-- Some convenience functions for testing lengths

-- Needs to be Maybe rather than Dec, because if 'n' is unequal to m, we
-- only know we don't know how to make a Vect n a, not that one can't exist.
export
exactLength : {m : Nat} -> -- expected at run-time
              (len : Nat) -> (xs : Vect m a) -> Maybe (Vect len a)
exactLength {m} len xs with (decEq m len)
  exactLength {m = m} m xs | (Yes Refl) = Just xs
  exactLength {m = m} len xs | (No contra) = Nothing

||| If the given Vect is at least the required length, return a Vect with
||| at least that length in its type, otherwise return Nothing
||| @len the required length
||| @xs the vector with the desired length
export
overLength : {m : Nat} -> -- expected at run-time
             (len : Nat) -> (xs : Vect m a) -> Maybe (p ** Vect (plus p len) a)
overLength n xs with (cmp m n)
  overLength {m}   (plus m (S y)) xs | (CmpLT y) = Nothing
  overLength {m}                m xs | CmpEQ     = Just (0 ** xs)
  overLength {m = plus n (S x)} n xs | (CmpGT x)
         = Just (S x ** rewrite plusCommutative (S x) n in xs)


doPlus : Nat -> Nat -> Nat
doPlus x y = x `plus` y

doMult : Nat -> Nat -> Nat
doMult x y = x `mult` y

doMinus : Nat -> Nat -> Nat
doMinus x y = x `minus` y

doEqual : (m, n : Nat) -> Bool
doEqual m n = m `equalNat` n

doCompare : (m, n : Nat) -> Ordering
doCompare m n = m `compareNat` n


module Invincy.Core

%access public export

interface Monoid s => Stream t s | s where
  single : t -> s
  uncons : s -> Maybe (t, s)
  cons : t -> s -> s
  cons x s = single x <+> s

implementation Stream t (List t) where
  single = pure
  uncons (x::xs) = Just (x, xs)
  uncons [] = Nothing
  cons = (::)

implementation Stream Char String where
  single = singleton
  uncons s = case strM s of
    StrNil => Nothing
    StrCons x xs => Just (x, xs)
  cons = strCons

fromString : Stream Char s => String -> s
fromString = concatMap single . unpack

toList : Stream t s => s -> List t
toList s = case uncons s of
  Nothing => []
  Just (x, xs) => x :: toList xs

fromList : Stream t s => List t -> s
fromList [] = neutral
fromList (x::xs) = cons x $ fromList xs


--- Day 1: Sonar Sweep ---

module SonarSweep
import System
import System.File
import Data.List
import Data.String

countIncreased : (nums : List Integer) -> List Integer
countIncreased nums = zipWith (\a, b => if b > a then 1 else 0) nums $ drop 1 nums

countIncreased3 : (nums: List Integer) -> List Integer
countIncreased3 nums = countIncreased $ sum <$> transpose [drop 2 nums, drop 1 nums, nums]

main : IO ()
main = do
      args <- getArgs
      let (file :: _) = drop 1 args | [] => printLn "No file provided!"
      (Right symbols) <- readFile file | (Left error) => printLn error
      let nums = catMaybes $ parsePositive <$> lines symbols
      (printLn . sum) $ countIncreased nums
      (printLn . sum) $ countIncreased3 nums


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

> {-

> ---}


module Utils.Num

import Data.Vect

alphabets : Vect 36 Char
alphabets = fromList $ unpack "0123456789abcdefghijklmnopqrstuvwxyz"

-- Use integer for performance reason
export
stringToNat' : Fin 36 -> String -> Maybe Integer
stringToNat' base str = if str == "" then Nothing else go (finToInteger base) 1 0 $ reverse $ unpack str
  where
    go : Integer -> Integer -> Integer -> List Char -> Maybe Integer
    go base' yoyo acc [] = Just acc
    go base' yoyo acc (chr :: xs) = do
      i <- elemIndex chr alphabets
      if i < base then go base' (base' * yoyo) (acc + finToInteger i * yoyo) xs else Nothing

export
stringToNat : Fin 36 -> String -> Maybe Nat
stringToNat base string = integerToNat <$> stringToNat' base string

export
stringToInteger : Fin 36 -> String -> Maybe Integer
stringToInteger base str =
  case strUncons str of
    Just ('-', num) => negate <$> stringToNat' base num
    Just ('+', num) => stringToNat' base num
    _ => stringToNat' base str


-- 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


||| An implementation of `Data.Heap` based on binomial trees.
||| This implementation is an adaptation of Okasaki's `BinomialHeap`
||| found on pp.20-25 of his book.
||| SEe also:
||| * [BinomialHeap in Agda](https://github.com/ericpony/FLOLAC-2014/blob/master/Analysis%20and%20synthesis%20of%20inductive%20families/Examples/BinomialHeap.agda)
||| *  [BinomialHeap in Haskell](https://jaspervdj.be/posts/2018-09-04-binomial-heaps-101.html#binomial-heaps-lets-build-it-up)
module Data.Heap.BinomialHeap

import Data.Vect

import public Data.Binary

%access public export
%default total

mutual
  ||| A Binomial Tree
  ||| quoting Okasaki:
  ||| A binomial tree is inductively defined as:
  ||| * a binomial tree of rank 0 is a singleton node
  ||| * a binomial tree of rank (n+1) is formed by linking 2 binomial trees
  |||   of rank n, making one tree the leftmost child of the other
  |||
  ||| Equivalently, a binomial tree of rank `r` is a tree with
  ||| `r` children `t_1 .. t_r` where each `t_i` has rank `r - i`.
  data BinTree : (rank : Nat) -> Type -> Type where
    MkTree : (elem : a) -> (subs : Children rank a) -> BinTree rank a

  ||| A helper type for children of a binomial tree, ensuring
  ||| subtrees are stored in increasing rank order.
  data Children : (rank : Nat) -> Type -> Type where
    CNil : Children 0 a
    CCons : BinTree k a -> Children k a -> Children (S k) a

||| A singleton binomial tree
Singleton : a -> BinTree 0 a
Singleton x = MkTree x CNil

||| Basic operation to _grow_ binomial trees
||| Takes 2 trees of equal rank `r` and forms a new tree of rank `S r`
link : (Ord a) => (left : BinTree r a) -> (right : BinTree r a) -> BinTree (S r) a
link left@(MkTree elem subs) right@(MkTree elem' subs') =
  if elem <= elem'
  then MkTree elem (CCons right subs)
  else MkTree elem' (CCons left subs')

||| A `Forest` is a list of `BinTree` with rank at most `rank`
||| @rank The rank of the largest `BinTree` contained in the Forest
||| @bin the `Binary` encoding of the occupied positions in this `Forest`. There
|||      is a tree at index `i` if the corresponding bit is `B1`
||| @a the type of elements contained in this forest
data Forest : (rank : Nat) -> (bin : Binary v) -> (a : Type) -> Type where
  FEnd : Forest rank BEnd a
  F0   :                   Forest (S rank) b a -> Forest rank (B0 b) a
  F1   : BinTree rank a -> Forest (S rank) b a -> Forest rank (B1 b) a

emptyForest : Forest rank BEnd a
emptyForest = FEnd

insertTree : (Ord a) => BinTree rank a -> Forest rank b a -> Forest rank (inc b) a
insertTree tree FEnd              = F1 tree FEnd
insertTree tree (F0 forest)       = F1 tree forest
insertTree tree (F1 tree' forest) = F0 (insertTree (link tree tree') forest)

mergeForests : (Ord a) => Forest rank b a -> Forest rank b' a
             -> Forest rank (add b b') a
mergeForests FEnd right {b'}   = rewrite sym (natIsBinary b') in right
mergeForests left FEnd {b} = ?hole
mergeForests _  _  = ?hole


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 Utils.Hex

import Data.List
import Data.Primitives.Views

%default total

hexDigit : Int -> Char
hexDigit 0 = '0'
hexDigit 1 = '1'
hexDigit 2 = '2'
hexDigit 3 = '3'
hexDigit 4 = '4'
hexDigit 5 = '5'
hexDigit 6 = '6'
hexDigit 7 = '7'
hexDigit 8 = '8'
hexDigit 9 = '9'
hexDigit 10 = 'a'
hexDigit 11 = 'b'
hexDigit 12 = 'c'
hexDigit 13 = 'd'
hexDigit 14 = 'e'
hexDigit 15 = 'f'
hexDigit _ = 'X' -- TMP HACK: Ideally we'd have a bounds proof, generated below

||| Convert a positive integer into a list of (lower case) hexadecimal characters
export
asHex : Int -> String
asHex n =
  if n > 0
    then pack $ asHex' n []
    else "0"
  where
    asHex' : Int -> List Char -> List Char
    asHex' 0 hex = hex
    asHex' n hex with (n `divides` 16)
      asHex' (16 * div + rem) hex | DivBy div rem _ =
        asHex' (assert_smaller n div) (hexDigit rem :: hex)

export
leftPad : Char -> Nat -> String -> String
leftPad paddingChar padToLength str =
  if length str < padToLength
    then pack (List.replicate (minus padToLength (length str)) paddingChar) ++ str
    else str

export
fromHexDigit : Char -> Maybe Int
fromHexDigit '0' = Just 0
fromHexDigit '1' = Just 1
fromHexDigit '2' = Just 2
fromHexDigit '3' = Just 3
fromHexDigit '4' = Just 4
fromHexDigit '5' = Just 5
fromHexDigit '6' = Just 6
fromHexDigit '7' = Just 7
fromHexDigit '8' = Just 8
fromHexDigit '9' = Just 9
fromHexDigit 'a' = Just 10
fromHexDigit 'b' = Just 11
fromHexDigit 'c' = Just 12
fromHexDigit 'd' = Just 13
fromHexDigit 'e' = Just 14
fromHexDigit 'f' = Just 15
fromHexDigit _ = Nothing

export
fromHexChars : List Char -> Maybe Int
fromHexChars = fromHexChars' 1
  where
    fromHexChars' : Int -> List Char -> Maybe Int
    fromHexChars' _ [] = Just 0
    fromHexChars' m (d :: ds) = pure $ !(fromHexDigit (toLower d)) * m + !(fromHexChars' (m*16) ds)

export
fromHex : String -> Maybe Int
fromHex = fromHexChars . unpack


import Data.Vect

--data Option t = Some t | None
data Option : (t:Type) -> Type where
  Some : (value:t) -> Option t
  None : Option t

add : Int -> Int -> Int
add x y = x + y

StringOrNat : Nat -> Type
StringOrNat Z = String
StringOrNat (S K) = Nat

divide : (x:Nat) -> (y:Nat) -> StringOrNat y
divide x Z = "Divisor was 0"
divide x y @ (S k) = div x y


module Data.Bifunctor

%access public export

--------------------------------------------------------------------------------
-- Interfaces
--------------------------------------------------------------------------------

interface Bifunctor (f : Type -> Type -> Type) where
  bimap : (a -> b) -> (c -> d) -> f a c -> f b d

interface Bifunctor f => VerifiedBifunctor (f : Type -> Type -> Type) where
  bifunctorIdentity : {a, b : Type} -> (x : f a b) -> bimap Basics.id Basics.id x = Basics.id x
  bifunctorComposition : {a, b, c, d, e, g : Type} -> (x : f a b) ->
                         (f1 : a -> c) -> (f2 : c -> d) ->
                         (g1 : b -> e) -> (g2 : e -> g) ->
                         bimap (f2 . f1) (g2 . g1) x = (bimap f2 g2 . bimap f1 g1) x

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

Bifunctor Either where
  bimap f _ (Left l) = Left (f l)
  bimap _ g (Right r) = Right (g r)

VerifiedBifunctor Either where
  bifunctorIdentity (Left l) = Refl
  bifunctorIdentity (Right r) = Refl
  bifunctorComposition (Left l) f1 f2 g1 g2 = Refl
  bifunctorComposition (Right r) f1 f2 g1 g2 = Refl

Bifunctor Pair where
  bimap f g (a, b) = (f a, g b)

VerifiedBifunctor Pair where
  bifunctorIdentity (a, b) = Refl
  bifunctorComposition (a, b) f1 f2 g1 g2 = Refl

--------------------------------------------------------------------------------
-- Functions
--------------------------------------------------------------------------------

-- | Map a function over the first type argument of a `Bifunctor`.
lmap : Bifunctor f => (a -> b) -> f a c -> f b c
lmap f = bimap f id

-- | Map a function over the second type arguments of a `Bifunctor`.
rmap : Bifunctor f => (b -> c) -> f a b -> f a c
rmap = bimap id


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!"


||| Logic for manipulating combat odds
module Bautzen.Odds

import Prelude.Bound
import Prelude.Enum

import Data.Fin
import Data.Nat.DivMod

||| The raw odds in a combat, basically a glorified pair.
public export
record RawOdds where
  constructor MkRawOdds

  ||| Raw attack factor
  attackFactor : Nat

  ||| Raw defense factor
  ||| TODO make it a positive so that we prevent stupid odds from
  ||| happening
  defenseFactor : Nat

public export
Semigroup RawOdds where
  (<+>) (MkRawOdds atk def) (MkRawOdds atk' def') = MkRawOdds (atk + atk') (def + def')

||| The actual odds representing a column in the combat table
public export
data Odds : Type where
  OneVsTwo : Odds
  OneVsOne : Odds
  TwoVsOne : Odds
  ThreeVsOne : Odds
  FourVsOne : Odds
  FiveVsOne : Odds
  SixVsOne : Odds
  SevenVsOne : Odds

public export
Eq Odds where
  OneVsTwo == OneVsTwo = True
  OneVsOne == OneVsOne = True
  TwoVsOne == TwoVsOne = True
  ThreeVsOne == ThreeVsOne = True
  FourVsOne == FourVsOne = True
  FiveVsOne == FiveVsOne = True
  SixVsOne == SixVsOne = True
  SevenVsOne == SevenVsOne = True
  _ == _ = False

public export
Enum Odds where
  pred OneVsTwo = OneVsTwo
  pred OneVsOne = OneVsTwo
  pred TwoVsOne = OneVsOne
  pred ThreeVsOne = TwoVsOne
  pred FourVsOne = ThreeVsOne
  pred FiveVsOne = FourVsOne
  pred SixVsOne = FiveVsOne
  pred SevenVsOne = SixVsOne

  succ OneVsTwo = OneVsOne
  succ OneVsOne = TwoVsOne
  succ TwoVsOne = ThreeVsOne
  succ ThreeVsOne = FourVsOne
  succ FourVsOne = FiveVsOne
  succ FiveVsOne = SixVsOne
  succ SixVsOne = SevenVsOne
  succ SevenVsOne = SevenVsOne

  toNat OneVsTwo = 0
  toNat OneVsOne = 1
  toNat TwoVsOne = 2
  toNat ThreeVsOne = 3
  toNat FourVsOne = 4
  toNat FiveVsOne = 5
  toNat SixVsOne = 6
  toNat SevenVsOne = 7

  fromNat Z = OneVsTwo
  fromNat (S k) = succ (fromNat k)

public export
Ord Odds where
  compare x y = compare (toNat x) (toNat y)

public export
MinBound Odds where
  minBound = OneVsTwo

public export
MaxBound Odds where
  maxBound = SevenVsOne

public export
toFin : Odds -> Fin 8
toFin OneVsTwo = 0
toFin OneVsOne = 1
toFin TwoVsOne = 2
toFin ThreeVsOne = 3
toFin FourVsOne = 4
toFin FiveVsOne = 5
toFin SixVsOne = 6
toFin SevenVsOne = 7

||| Transform a concrete attack/defense ratio into `Odds`
|||
||| The quotient is rounded to the lowest integer to produce `Odds`. By convention
||| if the `defenseFactor` is 0 the ratio is the greatest possible. This situation
||| should not happen
|||
||| @odds raw odds to transform into a column
public export
odds : (odds: RawOdds) -> Odds
odds (MkRawOdds attackFactor Z) = maxBound -- by convention, should not happen
odds (MkRawOdds attackFactor (S def)) with (attackFactor `divMod` def)
  odds (MkRawOdds (r + (q * (S def))) (S def)) | (MkDivMod q r _) = fromNat q

infixl 6 >>>
infixl 6 <<<

||| Shift odds by a given number of steps "up".
|||
||| @odds original odds
||| @steps number of steps to shift odds
public export
(>>>) : (odds : Odds) -> (steps : Nat) -> Odds
c >>> Z = c
c >>> (S k) = foldl (const . succ) c [0.. k]

||| Shift odds by a given number of steps "down".
|||
||| @odds original odds
||| @steps number of steps to shift odds
public export
(<<<) : (odds : Odds) -> (steps : Nat) -> Odds
c <<< Z = c
c <<< (S k) = foldl (const . pred) c [0.. k]

namespace OddsTest

  odds_are_rounded_down : odds (MkRawOdds 3 2) = OneVsOne
  odds_are_rounded_down = Refl

  odds_are_capped : odds (MkRawOdds 20 2) = SevenVsOne
  odds_are_capped = Refl

  odds_are_floored : odds (MkRawOdds 2 20) = OneVsTwo
  odds_are_floored = Refl


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


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

record MyDPair a (p : a -> Type) where
  constructor MkMyDPair
  dfst : a
  dsnd : p dfst

record DVect a where
  constructor MkDVect
  test : Int
  {n : Nat}
  vec : Vect n a

record Person where
  constructor MkPerson
  name : String
  age, shoesize : Int
  some_fn : b -> b -- 'b' bound as an argument to MkPerson

testPair : MyDPair Nat (\n => Vect n Int)
testPair = MkMyDPair _ [1,2,3,4,5]

testDVect : DVect Int
testDVect = MkDVect 94 [1,2,3,4,5]

testPerson : Person
testPerson = MkPerson "Wowbagger" 1337 10 (\x => S x)


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")])