-- For Sergey ;-)

module TypList

import Data.List.Elem

lst1 : List Type
lst1 = [Int]

lst2 : List Type
lst2 = [forall p. Num p => p]

au : Elem x xs => Elem x xs
au @{el} = el

f : Elem Int TypList.lst2
f = au

g : Elem (forall p. Num p => p) TypList.lst1
g = au


module VISD.Common

import Control.Isomorphism
import Data.BoundedList

%logging 1
%default total
%hide Prelude.Algebra.(<*>)
%hide Prelude.Applicative.(<|>)
%hide Prelude.Vect.reverse

-- http://www.informatik.uni-marburg.de/~rendel/unparse/

-- core definitions

data PartIso : Type -> Type -> Type where
  MkPartIso : (to : a -> Maybe b) ->
              (from : b -> Maybe a) ->
              (toFrom : (y : b) -> maybe () (\x => to x = Just y) (from y)) ->
              (fromTo : (x : a) -> maybe () (\y => from y = Just x) (to x)) ->
              PartIso a b

class PartIsoFunctor (f : Type -> Type -> Type) where
  (<$>) : PartIso a b -> f a c -> f b c

class PFunctor (f : Type -> Type -> Type) where
  (<*>) : f a c -> Lazy (f b c) -> f (a, b) c

class PAlternative (f : Type -> Type -> Type) where
  (<|>) : f a c -> Lazy (f a c) -> f a c
  empty : f a c

class (PartIsoFunctor d, PFunctor d, PAlternative d) => Syntax (d : Type -> Type -> Type) c where
  pure : Eq a => a -> d a c
  item : d c c

-- helper functions

ipc_inverse : PartIso a b -> PartIso b a
ipc_inverse (MkPartIso f g tf ft) = MkPartIso g f ft tf

ipc_apply : PartIso a b -> a -> Maybe b
ipc_apply (MkPartIso f g ft ft) = f

ipc_unapply : PartIso a b -> b -> Maybe a
ipc_unapply = ipc_apply . ipc_inverse

-- Inspect and other stuff

data Inspect : a -> Type where
  wi : {A : Type} -> (x : A) -> (y : A) -> (eq: x = y) -> Inspect x

inspect : {A : Type} -> (x : A) -> Inspect x
inspect x = wi x _ Refl

match : {A : Type} -> {x : A} -> (y : A) -> {eq : x = y} -> Inspect x
match y {eq} = wi _ y eq

maybe_assoc : (x : Maybe a) -> (f : a -> Maybe b) -> (g : b -> Maybe c) -> (x >>= (\y => f y >>= g)) = (x >>= f >>= g)
maybe_assoc Nothing f g = Refl
maybe_assoc (Just x) f g = Refl

maybe_unbind : (f : a -> Maybe b) -> (g : b -> Maybe c) -> (x : a) -> {y : b} ->
  (f x = Just y) -> g y = Just x >>= f >>= g
maybe_unbind f g x eq = rewrite eq in Refl

-- Algebra

infixr 1 >=>
(>=>) : Monad m => (a -> m b) -> (b -> m c) -> (a -> m c)
f >=> g = \x => f x >>= g

pId : PartIso a a
pId = MkPartIso (\x => Just x) (\x => Just x) (\x => Refl) (\x => Refl)

infixl 9 ..
(..) : PartIso b c -> PartIso a b -> PartIso a c
(MkPartIso gTo gFrom gTF gFT) .. (MkPartIso fTo fFrom fTF fFT) =
  MkPartIso
    (ipc_apply (MkPartIso fTo fFrom fTF fFT) >=> ipc_apply (MkPartIso gTo gFrom gTF gFT))
    (ipc_unapply (MkPartIso gTo gFrom gTF gFT) >=> ipc_unapply (MkPartIso fTo fFrom fTF fFT))
    tf ft
  where
    tf y with (inspect $ (gFrom y))
      | match Nothing {eq} = rewrite eq in ()
      | match (Just z) {eq} = rewrite eq in case (inspect $ fFrom z) of
        match Nothing {eq=eq1} => rewrite eq1 in ()
        match (Just n) {eq=eq1} => rewrite eq1 in
          rewrite (replace eq1 {P=(\pz => maybe () (\x => fTo x = Just z) pz)} (fTF z)) in
            (replace eq {P=(\py => maybe () (\x => gTo x = Just y) py)} (gTF y))
    ft x with (inspect $ (fTo x))
      | match Nothing {eq} = rewrite eq in ()
      | match (Just z) {eq} = rewrite eq in case (inspect $ gTo z) of
        match Nothing {eq=eq1} => rewrite eq1 in ()
        match (Just n) {eq=eq1} => rewrite eq1 in
          rewrite (replace eq1 {P=(\pz => maybe () (\x => gFrom x = Just z) pz)} (gFT z)) in
            (replace eq {P=(\py => maybe () (\y => fFrom y = Just x) py)} (fFT x))

commute : PartIso (a, b) (b, a)
commute = MkPartIso f f (\(a,b) => Refl) (\(a,b) => Refl) where
  f : (c, d) -> Maybe (d, c)
  f (a, b) = Just (b, a)

unit : {a : Type} -> PartIso a (a, ())
unit = MkPartIso f g tf ft where
  f : {a : Type} -> a -> Maybe (a, ())
  f a = Just (a, ())
  g : {a : Type} -> (a, ()) -> Maybe a
  g (a, ()) = Just a
  tf (a, ()) = Refl
  ft a = Refl

-- *>, <*

infixl 3 *>
(*>) : Syntax d c => d () c -> d a c -> d a c
p *> q = ipc_inverse unit .. commute <$> p <*> q

infixl 3 <*
(<*) : Syntax d c => d a c -> d () c -> d a c
p <* q = ipc_inverse unit <$> p <*> q

-- the following function can't be verified: there's no isomorphism
-- when we are ignoring input; neither can it be changed, because it's
-- quite important to be able to ignore input

ignore : a -> PartIso a ()
ignore x = MkPartIso f g tf ft where
  f : a -> Maybe ()
  f y = Just ()
  g : () -> Maybe a
  g () = Just x
  tf () = Refl
  ft y = believe_me (Just x = Just y)

-- Parser

data Parser a c = MkParser (List c -> Maybe (a, List c))

parse : Parser a c -> List c -> Maybe a
parse (MkParser p) s = p s >>= pure . fst

instance PartIsoFunctor Parser where
  iso <$> (MkParser p) = MkParser pf
  where
    pf l = do
      (x, rest) <- p l
      y <- ipc_apply iso x
      return (y, rest)

instance PFunctor Parser where
  (MkParser p) <*> mkpq = MkParser pf
  where
    pf l = do
      (x, rest) <- p l
      case mkpq of
        (MkParser q) => do
          (y, ret) <- q rest
          return ((x, y), ret)

instance PAlternative Parser where
  (MkParser p) <|> mkpq = MkParser pf
  where
    pf l = case p l of
      Just x => Just x
      Nothing => case mkpq of
        (MkParser q) => q l
  empty = MkParser (\s => Nothing)

instance Syntax Parser c where
  pure x = MkParser (\s => Just (x, s))
  item = MkParser f
  where
    f [] = Nothing
    f (x :: xs) = Just (x, xs)

-- Printer

data Printer a c = MkPrinter (a -> Maybe (List c))

compose : Printer a c -> a -> Maybe (List c)
compose (MkPrinter p) x = p x

instance PartIsoFunctor Printer where
  iso <$> (MkPrinter p) = MkPrinter (\b => ipc_unapply iso b >>= p)

instance PFunctor Printer where
  (MkPrinter p) <*> mkpq = MkPrinter pf
  where
    pf (x, y) = do
      x' <- p x
      case mkpq of
        (MkPrinter q) => do
          y' <- q y
          return (x' ++ y')

instance PAlternative Printer where
  (MkPrinter p) <|> mkpq = MkPrinter $ \s =>
    case (p s) of
      Nothing => case mkpq of
        (MkPrinter q) => q s
      x => x
  empty = MkPrinter (\s => Nothing)

instance Syntax Printer c where
  pure x = MkPrinter (\y =>
    if x == y
    then Just []
    else Nothing)
  item = MkPrinter (\t => Just [t])

-- Basic parsers/composers

sat : Syntax d a => (a -> Bool) -> d a a
sat {a} p = (MkPartIso check check verify verify) <$> item
  where
    check : a -> Maybe a
    check x = if p x then Just x else Nothing
    verify y with (inspect $ p y)
      | match False {eq=eq} = rewrite eq in ()
      | match True {eq=eq} = rewrite eq in
        rewrite eq in Refl

val : (Syntax d a, Eq a) => a -> d a a
val x = sat (== x)

-- rep

nilv : PartIso () (Vect 0 a)
nilv = MkPartIso to from tf ft
  where
    to : () -> Maybe (Vect 0 a)
    to () = Just $ Vect.Nil {a=a}
    from : (Vect 0 a) -> Maybe ()
    from [] = Just ()
    from _ = Nothing
    tf [] = Refl
    ft () = Refl

consv : PartIso (a, Vect n a) (Vect (S n) a)
consv = MkPartIso c1 c2 tf ft
  where
    c1 : (a, Vect n a) -> Maybe (Vect (S n) a)
    c1 (x, xs) = Just (x :: xs)
    c2 : (Vect (S n) a) -> Maybe (a, Vect n a)
    c2 (x :: xs) = Just (x, xs)
    tf (x :: xs) = Refl
    ft (a, b) = Refl

rep : Syntax d c => (n : Nat) -> d a c -> d (Vect n a) c
rep Z p = nilv <$> pure ()
rep (S k) p = consv <$> p <*> rep k p

-- up to

bNil : PartIso () (BoundedList n a)
bNil = MkPartIso to from tf ft
  where
    to : () -> Maybe (BoundedList n a)
    to () = Just []
    from : BoundedList n a -> Maybe ()
    from [] = Just ()
    from _ = Nothing
    tf [] = Refl
    tf (x::xs) impossible
    ft () = Refl

bCons : PartIso (a, BoundedList n a) (BoundedList (S n) a)
bCons = MkPartIso to from tf ft
  where
    to : (a, BoundedList n a) -> Maybe (BoundedList (S n) a)
    to (x, l) = Just $ x :: l
    from : BoundedList (S n) a -> Maybe (a, BoundedList n a)
    from [] = Nothing
    from (x :: xs) = Just (x, xs)
    tf [] = ()
    tf (x :: xs) = Refl
    ft (x, l) = Refl

upTo : Syntax d c => (n: Nat) -> d a c -> d (BoundedList n a) c
upTo Z _ = (bNil <$> pure ())
upTo (S n) p = (bCons <$> (p <*> (upTo n p)))
           <|> (bNil <$> pure ())

bounded : Syntax d c => (min,add: Nat) -> d a c -> d (Vect min a, BoundedList add a) c
bounded min add p = rep min p <*> upTo add p

-- maybe

just : PartIso a (Maybe a)
just = MkPartIso (Just . Just) id tf ft
  where
    tf Nothing = ()
    tf (Just x) = Refl
    ft _ = Refl

nothing : PartIso () (Maybe a)
nothing = MkPartIso to from tf ft
  where
    to : () -> Maybe (Maybe a)
    to x = Just Nothing
    from : Maybe a -> Maybe ()
    from (Just x) = Nothing
    from Nothing = Just ()
    tf (Just x) = ()
    tf Nothing = Refl
    ft () = Refl

maybe : Syntax d c => d a c -> d (Maybe a) c
maybe p = (just <$> p)
      <|> (nothing <$> pure ())

-- many

nil : PartIso () (List a)
nil = MkPartIso c1 c2 tf ft
  where
    c1 : () -> Maybe (List a)
    c1 () = Just []
    c2 : List a -> Maybe ()
    c2 [] = Just ()
    c2 (x :: xs) = Nothing
    tf [] = Refl
    tf (x :: xs) = ()
    ft () = Refl

cons : PartIso (a, List a) (List a)
cons = MkPartIso c1 c2 tf ft
  where
    c1 : (a, List a) -> Maybe (List a)
    c1 (x, l) = Just $ x :: l
    c2 : List a -> Maybe (a, List a)
    c2 [] = Nothing
    c2 (x :: xs) = Just (x, xs)
    tf [] = ()
    tf (x :: xs) = Refl
    ft (x, l) = Refl

partial many : Syntax d c => d a c -> d (List a) c
many p = (cons <$> (p <*> (many p)))
     <|> (nil <$> pure ())

-- sepBy1

partial sepBy1 : Syntax d c => d a c -> d b c -> b -> d (List a) c
sepBy1 p s x = cons <$> (p <*> (many ((ignore x <$> s) *> p)))


module Sub12Apply108x90

import ProofColDivSeqBase
import ProofColDivSeqPostulate

%default total
-- %language ElabReflection

-- 3(36x+30) --F[5,-2]->B[1,-2]--> 3(16x+13)
fb108x90To48x39 :
  (o:Nat) -> P (S (S (S (S (S (S (plus (plus (plus (plus (plus (plus o o) o) (S (S (plus (plus o o) o))))
                                              (S (S (plus (plus (plus o o) o) (S (S (plus (plus o o) o)))))))
                                        (S (S (S (plus (plus (plus (plus o o) o) (S (S (plus (plus o o) o)))) (S (S (plus (plus (plus o o) o) (S (S (plus (plus o o) o)))))))))))  (S (S (S (plus (plus (plus (plus o o) o) (S (S (plus (plus o o) o))))
                                                 (S (S (plus (plus (plus o o) o) (S (S (plus (plus o o) o))))))))))))))))) 2
    -> P (S (S (S (S (S (S (S (S (S (S (S (S (S (plus (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o))) (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o))))))))))))))))) 2
fb108x90To48x39 o prf =
  let prf2 = lvDown (S (S (S (S (S (S (plus (plus (plus (plus (plus (plus o o) o) (S (S (plus (plus o o) o))))
                                              (S (S (plus (plus (plus o o) o) (S (S (plus (plus o o) o)))))))
                                        (S (S (S (plus (plus (plus (plus o o) o) (S (S (plus (plus o o) o)))) (S (S (plus (plus (plus o o) o) (S (S (plus (plus o o) o)))))))))))  (S (S (S (plus (plus (plus (plus o o) o) (S (S (plus (plus o o) o))))
                                                 (S (S (plus (plus (plus o o) o) (S (S (plus (plus o o) o))))))))))))))))) 2
                    prf in
    let prf3 = fb108x90To48x39' o prf2 in lvDown (S (S (S (S (S (S (S (S (S (S (S (S (S (plus (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o))) (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o))))))))))))))))) 3 prf3

export
apply108x90 : P (S (S (S (S (S (S (plus (plus (plus (plus (plus (plus o o) o) (S (S (plus (plus o o) o))))
                                              (S (S (plus (plus (plus o o) o) (S (S (plus (plus o o) o)))))))
                                        (S (S (S (plus (plus (plus (plus o o) o) (S (S (plus (plus o o) o)))) (S (S (plus (plus (plus o o) o) (S (S (plus (plus o o) o)))))))))))  (S (S (S (plus (plus (plus (plus o o) o) (S (S (plus (plus o o) o))))
                                                 (S (S (plus (plus (plus o o) o) (S (S (plus (plus o o) o))))))))))))))))) 2
  -> (m : Nat **
        (LTE (S m)
             (S (S (S (S (S (S (plus (plus (plus (plus (plus (plus o o) o) (S (S (plus (plus o o) o))))
                                                 (S (S (plus (plus (plus o o) o) (S (S (plus (plus o o) o)))))))
                                           (S (S (S (plus (plus (plus (plus o o) o) (S (S (plus (plus o o) o))))
                                                          (S (S (plus (plus (plus o o) o) (S (S (plus (plus o o) o)))))))))))
                                     (S (S (S (plus (plus (plus (plus o o) o) (S (S (plus (plus o o) o))))
                                                    (S (S (plus (plus (plus o o) o) (S (S (plus (plus o o) o))))))))))))))))),
         P m 2))
apply108x90 {o} col = let col2 = fb108x90To48x39 o col in ((S (S (S (S (S (S (S (S (S (S (S (S (S (plus (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o))) (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o)))))))))))))))))
                                                           ** (lte108x90 o, col2)) where
  lte108x90 : (o:Nat) -> LTE (S (S (S (S (S (S (S (S (S (S (S (S (S (S (plus (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o)))
                                                          (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o))))))))))))))))))
          (S (S (S (S (S (S (plus (plus (plus (plus (plus (plus o o) o) (S (S (plus (plus o o) o))))
                                              (S (S (plus (plus (plus o o) o) (S (S (plus (plus o o) o)))))))
                                        (S (S (S (plus (plus (plus (plus o o) o) (S (S (plus (plus o o) o)))) (S (S (plus (plus (plus o o) o) (S (S (plus (plus o o) o)))))))))))                                  (S (S (S (plus (plus (plus (plus o o) o) (S (S (plus (plus o o) o))))
                                                 (S (S (plus (plus (plus o o) o) (S (S (plus (plus o o) o)))))))))))))))))
  lte108x90 Z = (lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc) LTEZero
  lte108x90 (S o) = let lemma = lte108x90 o in
    rewrite (sym (plusSuccRightSucc o o)) in
    rewrite (sym (plusSuccRightSucc (plus o o)  (S (plus o o)))) in
    rewrite (sym (plusSuccRightSucc (plus o o)  (plus o o))) in
    rewrite (sym (plusSuccRightSucc (plus (plus o o) (plus o o))  (S (S (S (plus (plus o o) (plus o o))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus o o) (plus o o))  (S (S (plus (plus o o) (plus o o)))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus o o) (plus o o))  (S (plus (plus o o) (plus o o))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus o o) (plus o o))  (plus (plus o o) (plus o o)))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o)))  (S (S (S (S (S (S (S (plus (plus (plus o o) (plus o o))
                                                            (plus (plus o o) (plus o o)))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o)))  (S (S (S (S (S (S (plus (plus (plus o o) (plus o o))
                                                            (plus (plus o o) (plus o o))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o)))  (S (S (S (S (S (plus (plus (plus o o) (plus o o))
                                                            (plus (plus o o) (plus o o)))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o)))  (S (S (S (S (plus (plus (plus o o) (plus o o))
                                                            (plus (plus o o) (plus o o))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o)))  (S (S (S (plus (plus (plus o o) (plus o o))
                                                            (plus (plus o o) (plus o o)))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o)))  (S (S (plus (plus (plus o o) (plus o o))
                                                            (plus (plus o o) (plus o o))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o)))  (S (plus (plus (plus o o) (plus o o))
                                                            (plus (plus o o) (plus o o)))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o)))  (plus (plus (plus o o) (plus o o))
                                                            (plus (plus o o) (plus o o))))) in

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

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

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

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

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


module Js.Typeable

import Pruviloj.Core
import Data.Vect

%language ElabReflection

public export
data TypeRep : Type -> Type where
  TRString : TypeRep String
  TRInteger : TypeRep Integer
  TUnit : TypeRep ()
  TRCons : String -> List String -> (a: Type) -> TypeRep a
  TRCons1 : String -> List String -> (a: Type) -> (f: Type->Type) -> TypeRep a -> TypeRep (f a)
  TRCons2 : String -> List String -> (a: Type) -> (b: Type) -> (f: Type->Type->Type) ->
                TypeRep a -> TypeRep b -> TypeRep (f a b)
  TRCons_Nat : String -> List String -> (f: Nat -> Type) -> (n: Nat) -> TypeRep (f n)
  TRFun : TypeRep a -> TypeRep b -> TypeRep (a -> b)

same : TypeRep a -> TypeRep b -> Bool
same TRString TRString = True
same TRInteger TRInteger = True
same TUnit TUnit = True
same (TRCons x1 y1 _) (TRCons x2 y2 _) = x1 == x2 && y1 == y2
same (TRCons1 x1 y1 _ _ z1) (TRCons1 x2 y2 _ _ z2) = x1 == x2 && y1 == y2 && same z1 z2
same (TRCons2 x1 y1 _ _ _ z1 w1) (TRCons2 x2 y2 _ _ _ z2 w2) = x1 == x2 && y1 == y2 && same z1 z2 && same w1 w2
same (TRCons_Nat x1 y1 _ z1) (TRCons_Nat x2 y2 _ z2) = x1 == x2 && y1 == y2 && z1 == z2
same (TRFun x1 y1) (TRFun x2 y2) = same x1 x2 && same y1 y2
same _ _ = False

export
interface Typeable (a: Type) where
  getTypeRep : TypeRep a

export
tcast : (Typeable a, Typeable b) => a -> Maybe b
tcast {a} {b} x =
  if same (the (TypeRep a) getTypeRep) (the (TypeRep b) getTypeRep) then Just $ believe_me x
    else Nothing

useGetTypeRep : Elab ()
useGetTypeRep =
  do
    [_, s2] <- apply (Var `{getTypeRep}) [True, False]
    solve
    focus s2
    hypothesis

deriveTCons1 : String -> List String -> TTName -> Elab ()
deriveTCons1 name modName x=
  do
    [sub] <- apply `(TRCons1 ~(quote name) ~(quote modName) ~(Var x) ~(Var (NS (UN name) modName))) [False]
    solve
    focus sub
    useGetTypeRep

deriveTCons_Nat : String -> List String -> Elab ()
deriveTCons_Nat name modName =
  do
    [_] <- apply `(TRCons_Nat ~(quote name) ~(quote modName) ~(Var (NS (UN name) modName))) [True]
    solve

deriveTypeableAux : TTName -> TT -> Elab ()
deriveTypeableAux dname val =
  case val of
    P (TCon _ 0) (NS (UN name) modName) _ =>
      do
        fill `(TRCons ~(quote name) ~(quote modName) ~(Var (NS (UN name) modName)))
        solve
    App
      (P (TCon _ 1) (NS (UN name) modName) _)
      (P Bound x _) =>
        deriveTCons1 name modName x <|> deriveTCons_Nat name modName
    App
      (App
        (P (TCon _ 2) (NS (UN name) modName) _)
        (P Bound x _))
      (P Bound y _) =>
        do
          [sub1, sub2] <- apply
                    `(TRCons2 ~(quote name) ~(quote modName) ~(Var x) ~(Var y) ~(Var (NS (UN name) modName)))
                    [False, False]
          solve
          focus sub1
          useGetTypeRep
          focus sub2
          useGetTypeRep
    other => fail [ TermPart other
                  , TextPart "cannot make typeable"
                  ]

export
deriveTypeable : Elab ()
deriveTypeable =
  do
    (ng,tg) <- getGoal
    case tg of
      `(TypeRep ~val) =>
        deriveTypeableAux ng val
      otherGoal => fail [ TermPart otherGoal
                        , TextPart "has an unexpected form for getTypeRep?"
                        ]

export
Typeable String where
  getTypeRep = TRString

export
Typeable Integer where
  getTypeRep = TRInteger

export
(Typeable a, Typeable b) => Typeable (a->b) where
  getTypeRep = TRFun getTypeRep getTypeRep

export
Typeable Bool where
  getTypeRep = %runElab deriveTypeable

export
Typeable () where
  getTypeRep = TUnit

export
Typeable Nat where
  getTypeRep = %runElab deriveTypeable

export
Typeable a => Typeable (Maybe a) where
  getTypeRep = %runElab deriveTypeable

export
Typeable a => Typeable (List a) where
  getTypeRep = %runElab deriveTypeable

export
(Typeable a, Typeable b) => Typeable (Either a b) where
  getTypeRep = %runElab deriveTypeable

export
Typeable (Fin n) where
  getTypeRep = %runElab deriveTypeable

export
(Typeable a, Typeable b) => Typeable (a, b) where
  getTypeRep = %runElab deriveTypeable


module Doc

||| World!
export
world : Nat -> Nat
world x = x*2

nope : Nat
nope = 0

export
||| Hello!
hello : Int -> Int
hello x = x*2


%language ElabReflection

triv : Elab ()
triv =
    do
        compute
        g <- getGoal
        case (snd g) of
            `(() : Type) =>
                do
                    fill `(() : ())
                    solve
            otherGoal =>
                fail [
                    TermPart otherGoal,
                    TextPart "is not trivial"
                ]

mkId : Elab ()
mkId =
    do
        intro `{{x}}
        fill (Var `{{x}})
        solve

idNat : Nat -> Nat
idNat = %runElab mkId

idUnit : () -> ()
idUnit = %runElab mkId

idString : String -> String
idString = %runElab mkId


module Vector

import DataTypes
import Control.ST
import Control.ST.Exception

%access public export

outOfBoundsError : String -> Integer -> List LispVal -> LispError
outOfBoundsError name index vec =
    Default $
        name ++
        ": index is out of range; " ++
        "index: " ++ show index ++ "; valid range: " ++ show (length vec)

isVector : PrimitiveLispFunc
isVector args = case args of
    [(LispVector n _)] => pure $ LispBool True
    [_] => pure $ LispBool False
    a => Left $ NumArgs (MinMax 1 1) (cast $ length args) a

vectorLength : PrimitiveLispFunc
vectorLength args = case args of
    [(LispVector n vec)] => pure $ LispInteger $ cast n
    [v] => Left $ TypeMismatch "Vector" v
    a => Left $ NumArgs (MinMax 1 1) (cast $ length args) a

vectorRef : PrimitiveLispFunc
vectorRef args =
  case args of
    [LispVector n vec, LispInteger m] =>
      case index' (fromIntegerNat m) vec of
        Just val => pure val
        Nothing => Left $ outOfBoundsError "vector-ref" m vec
    [v] => Left $ TypeMismatch "Vector" v
    a => Left $ NumArgs (MinMax 2 2) (cast $ length args) a

vectorPrimitives : List (String, PrimitiveLispFunc)
vectorPrimitives =
    [ ("vector?", isVector)
    , ("vector-length", vectorLength)
    , ("vector-ref", vectorRef)
    ]


module Control.Linear.LState

import Control.Linear

%default total

export
data LState : (stateType : Type) -> (a : Type) -> Type where
  MkLState : (1 f : ((1 _ : stateType) -> (LPair a stateType))) -> LState stateType a

export
Functor (LState stateType) where
  map f (MkLState c) = MkLState (\s => let (r # s') = c s in ((f r) # s'))

export
Applicative (LState stateType) where
  pure x = MkLState (\s => x # s)
  (MkLState cf) <*> (MkLState cv) = MkLState (\s =>
                                    let (f # s') = cf s
                                        (r # s'') = cv s'
                                        in ((f r) # s''))

export
LMonad (LState s) where
  (>>=) (MkLState f) c = MkLState (\x => let (res # s') = f x in
                                                 let (MkLState r2) = c res
                                                      in r2 s')

export
run : (f : (1 state : s) -> (LPair a s)) -> LState s a
run f = MkLState f

export
change : (f : (1 state : s) -> s) -> LState s ()
change f = MkLState (\state => (() # f state))

public export
interface SubState a b where
  liftSt : LState a r -> LState b r

export
SubState a (a, b) where
  liftSt (MkLState f) = MkLState (\(sa, sb) => let (res # sa') = f sa in
                                                  (res # (sa', sb)))

export
SubState a (b, a) where
  liftSt (MkLState f) = MkLState (\(sb, sa) => let (res # sa') = f sa in
                                                  (res # (sb, sa')))

export
runLState : (1 initState : stateType) -> (1 c : LState stateType r) -> LPair r stateType
runLState s (MkLState f) = f s

export
execLState : (1 initState : stateType) -> (1 c : LState stateType r) -> stateType
execLState s (MkLState f) = let (_ # finState) = f s in finState


palindrome : Nat -> String -> Bool
palindrome n str = let longEnough = (length str) > n
                   in longEnough && (isPalindrome str)
    where
      isPalindrome : String -> Bool
      isPalindrome s = (toLower s) == (toLower (reverse s))

showPalindrome : String -> String
showPalindrome str = "Word is palindrome: " ++ show (palindrome 0 str) ++ "\n"

main : IO ()
main = repl "> " showPalindrome


import Data.Vect

using (Show a, Eq a)
  foo : a -> String
  foo x = show x ++ show x

  bar : Int -> Int
  bar x = x + x

using (xs : Vect n a, n : Nat) -- get reordered in dependency order by
                               -- the usual implicit rules
  baz : xs = xs

data Test : Type -> Type -> Type where

using (Test a b)
  needle : a -> b -> ()
  nardle : a -> ()
  noo : b -> ()


module Reviewer

import Data.Nat
import Data.String
import Data.List
import Data.List.DeleteBy
import Data.List1
import System.Random.Node
import Text.PrettyPrint.Prettyprinter
import Text.PrettyPrint.Prettyprinter.Symbols
import Text.PrettyPrint.Prettyprinter.Render.Terminal
import Util

%default total

record Score login where
  constructor MkScore
  user          : login
  partialScore  : Nat
  combinedScore : Nat

loginScore : Score login -> (login, Nat)
loginScore (MkScore l s c) = (l, c)

||| Get scored reviewers sorted from lowest to highest score.
||| A low score indicates less review work (a better candidate for
||| assigning a new PR to).
|||
||| The resulting `Score` contains both a partial score (the score
||| based only on open reivews) and also a combined score (the score
||| after negatively weighting closed reviews).
|||
||| Closed reviews are negatively scored because they are review requests
||| that were not answered.
scoredReviewers : Ord login =>
                  (closedReviews : List login)
               -> (openReviews : List login)
               -> (candidates : List login)
               -> List (Score login)
scoredReviewers closedReviews openReviews candidates =
  let closedReviewsWeighted = weightReviews 1 closedReviews
      openReviewsWeighted   = weightReviews 4 openReviews
      allReviews            = zipReviews openReviewsWeighted closedReviewsWeighted Subtract False
  in sort' $ zipReviews allReviews (weightReviews 0 candidates) Add True
  where
      -- The number of appearances is multiplied by the supplied weight which
      -- allows us to weight some lists more heavily than others.
      weightReviews : (weight : Nat) -> List login -> List (Score login)
      weightReviews weight reviews =
        let grouped = groupAllWith id reviews
        in  grouped <&> (\xs => let score = (* weight) . length $ forget xs in (MkScore (head xs) score score))

      -- Sort logins by the number of times each login was requested for review.
      sort' : List (Score login) -> List (Score login)
      sort' = sortBy $ compare `on` combinedScore

      data Op = Add | Subtract

      -- Add or subtract the scores for any equal logins.
      -- If `filterToSecondList` then no elements in the first list
      -- but not the second list will be kept.
      zipReviews : List (Score login) -> List (Score login) -> Op -> (filterToSecondList : Bool) -> List (Score login)
      zipReviews [] [] _ _     = []
      zipReviews [] ys Add _   = ys
      zipReviews [] ys Subtract _ = { combinedScore := 0 } <$> ys
      zipReviews xs [] _ True  = []
      zipReviews xs [] _ False = xs
      zipReviews (x@(MkScore l1 s1 c1) :: xs) ys op filter =
        case (deleteBy' ((==) `on` user) x ys, filter) of
             ((Nothing      , ys'), False)      => (MkScore l1 s1 c1             ) :: zipReviews xs ys' op filter
             ((Nothing      , ys'), True )      =>                                    zipReviews xs ys' op filter
             ((Just (MkScore _ _ c2'), ys'), _) => (MkScore l1 s1 (c1 `calc` c2')) :: zipReviews xs ys' op filter
        where
          calc : Nat -> Nat -> Nat
          calc k j with (op)
            _ | Add      = k + j
            _ | Subtract = k `minus` j

||| Choose reviewers that maintain harmony in the review world.
||| Returns the logins of all reviewers that would work equally well.
|||
||| @ closedReviews   The logins of each reviewer of each closed PR (duplicates intact).
||| @ openReviews     The logins of each reviewer of each open PR (duplicates intact).
||| @ candidates      The logins of all potential reviewers that should be considered.
||| @ forcedReviewers The logins of all reviewers that are being forced (not chosen by harmony).
||| @ author          The author of the PR for which a reviewer is being picked.
export
chooseReviewers : Ord login =>
                  (closedReviews : List login)
               -> (openReviews : List login)
               -> (candidates : List login)
               -> (forcedReviewers : List login)
               -> (author : login)
               -> List (login, Nat)
chooseReviewers closedReviews openReviews candidates forcedReviewers author =
  let remainingOptions = (nub candidates) \\ (author :: forcedReviewers)
      scoredOptions    = scoredReviewers closedReviews openReviews remainingOptions
  in  case scoredOptions of
           [] => []
           ((MkScore l s c) :: xs) =>
             let rest  = takeWhile ((== c) . combinedScore) xs
                 rest' = loginScore <$> rest
             in  (l, c) :: rest'

export
randomReviewer : HasIO io => List (login, Nat) -> io (Maybe login)
randomReviewer [] = pure Nothing
randomReviewer (x :: xs) = (Just . fst) <$> rndSelect (x :: xs)

||| Produce a graph of relative review workload for all developers matching the given
||| filter.
||| @ closedReviews The logins of each reviewer of each closed PR (duplicates intact).
||| @ openReviews   The logins of each reviewer of each open PR (duplicates intact).
||| @ candidates    The logins of all potential reviewers that should be considered.
export
reviewsGraph : Ord login => Pretty login =>
               (closedReviews : List login)
            -> (openReviews : List login)
            -> (candidates : List login)
            -> Doc AnsiStyle
reviewsGraph closedReviews openReviews candidates =
  let scoredOptions = reverse $ scoredReviewers closedReviews openReviews (sort $ nub candidates)
  in  case scoredOptions of
           [] => emptyDoc
           ((MkScore _ s c) :: _) =>
             let highScore = c + (s `minus` c)
             in  header <+> graph (if highScore > 0 then highScore else 1) scoredOptions <+> line
  where
    yellowDot : Doc AnsiStyle
    yellowDot = annotate (color Yellow) "·"

    redDot : Doc AnsiStyle
    redDot = annotate (color Red) "◦"

    header : Doc AnsiStyle
    header = vsep [ emptyDoc
                  , pretty "Weighted review workload."
                  , pretty "4x the numbewr of open review requests" <++> parens yellowDot
                  , pretty "1x the number of closed PRs with unanswered review requests" <++> parens redDot
                  , parens $ redDot <++> pretty "overlayed on" <++> yellowDot
                  , emptyDoc
                  , emptyDoc
                  ]

    -- The "detractor" is an indication of the amount of the score that was taken
    -- away by the heuristic in `scoredReviewers` that weights closed reviews with
    -- unanswered review requests negatively.
    bar : (indentation : Nat) -> (score : Nat) -> (detractor : Nat) -> Doc AnsiStyle
    bar idt score detractor = indent (cast idt) . hcat $
                                [ annotate (color Red) . pretty $ replicate detractor '◦'
                                , annotate (color Yellow) . pretty $ replicate score '·'
                                ]

    graphOne : (highScore : Nat) -> (Score login) -> Doc AnsiStyle
    graphOne highScore (MkScore user partialScore combinedScore) =
      let idt    = highScore `minus` partialScore
          user   = annotate italic $ pretty user
          detractor = (partialScore `minus` combinedScore)
          remainingSpace = highScore `minus` combinedScore
          -- we create a bar with the combinedScore and then fill in any
          -- remaining space with an indication of the detractor. We cap
          -- the detractor representation at the high score to make everything
          -- line up nicely. The detractor is just there to give some indication
          -- of review requests that did not count positively toward the score.
      in  bar idt combinedScore (min remainingSpace detractor) <++> user

    graph : (highScore : Nat) -> List (Score login) -> Doc AnsiStyle
    graph highScore = vsep . map (graphOne highScore)


module YinYang

import Control.Monad.Trans
import src.ContT

data Rec : (r : Type) -> (m : Type -> Type) -> Type where
  RecK : (Rec r m -> ContT r m (Rec r m)) -> Rec r m

yin : ContT r IO (Rec r IO)
yin = do k <- callCC (\k => pure (RecK k))
         lift (putStrLn "")
         pure k

yang : ContT r IO (Rec r IO)
yang = do k <- callCC (\k => pure (RecK k))
          lift (putStr "*")
          pure k

yinyang : ContT r IO (Rec r IO)
yinyang = do (RecK k) <- yin
             k' <- yang
             k k'

test : IO ()
test = run (\_ => pure ()) yinyang


module Crypto.Hash

import Data.Bits
import Data.List
import Data.Nat
import Data.Vect
import public Crypto.Hash.Interfaces
import public Crypto.Hash.SHA2
import public Crypto.Hash.SHA1
import public Crypto.Hash.MD5

||| basically `Hash.initialize` but with explicit type argument
public export
init : (0 algo : Type) -> Hash algo => algo
init algo = initialize

||| hash a sequence of bytes and produce a digest
public export
hash : (0 algo : Type) -> Hash algo => (message : List Bits8) -> Vect (digest_nbyte {algo}) Bits8
hash algo xs = finalize $ update xs $ Hash.init algo

||| basically `MAC.initialize` but with explicit type argument
public export
init_mac : (0 algo : Type) -> MAC key algo => key -> algo
init_mac algo key = initialize_mac key

||| hash a sequence of bytes with key and produce a digest
public export
mac : (0 algo : Type) -> MAC key algo => key -> (message : List Bits8) -> Vect (digest_nbyte {algo}) Bits8
mac algo key xs = finalize $ update xs $ Hash.init_mac algo key


module Data.Vector

%default total
%access public export

export data Vector : Type -> Type

%extern prim__Vector_empty : Ptr
%extern prim__Vector_replicate : Nat -> Ptr -> Ptr
%extern prim__Vector_length : Ptr -> Nat
%extern prim__Vector_null : Ptr -> Bool
%extern prim__Vector_index : Ptr -> Nat -> Ptr
%extern prim__Vector_replaceAt : Nat -> Ptr -> Ptr -> Ptr
%extern prim__Vector_insertAt : Nat -> Ptr -> Ptr -> Ptr

||| O(1) Empty vector
empty : Vector a
empty = believe_me prim__Vector_empty

||| O(n) Vector of the given length with the same value in each position.
replicate : Nat -> a -> Vector a
replicate n x = believe_me (prim__Vector_replicate n (believe_me x))

||| O(1) Vector with exactly one element
singleton : a -> Vector a
singleton = replicate 1

||| O(1) Yield the length of the vector.
length : Vector a -> Nat
length xs = prim__Vector_length (believe_me xs)

||| O(1) Test whether a vector if empty
null : Vector a -> Bool
null xs = prim__Vector_null (believe_me xs)

infixl 10 !!

||| O(1) Indexing
(!!) : Vector a -> Nat -> a
(!!) xs i = believe_me (prim__Vector_index (believe_me xs) (believe_me i))

||| O(1) Safe Indexing
index' : Nat -> Vector a -> Maybe a
index' i xs = if (i < length xs) then Just (xs !! i) else Nothing

||| O(length xs) Insert new element.
unsafeInsertAt : Nat -> a -> Vector a -> Vector a
unsafeInsertAt n x xs = believe_me (prim__Vector_insertAt n (believe_me x) (believe_me xs))

||| O(length xs) Insert new element.
unsafeReplaceAt : Nat -> a -> Vector a -> Vector a
unsafeReplaceAt n x xs = believe_me (prim__Vector_replaceAt n (believe_me x) (believe_me xs))

||| O(length xs) Prepends an element.
(::) : a -> Vector a -> Vector a
(::) = unsafeInsertAt 0

||| O(1)
lastIndex : Vector a -> Maybe Nat
lastIndex xs =
  let
    n = length xs
  in
    case 1 `isLTE` n of
      Yes prf => Just (n - 1)
      _       => Nothing

elem : Eq a => a -> Vector a -> Bool
elem x xs =
  case length xs of
    Z   => False
    S k => go k
  where
    go : Nat -> Bool
    go Z = x == xs !! 0
    go i@(S k) = if x == xs !! i then True else go k

Foldable Vector where
  foldr f init xs =
    case length xs of
      Z   => init
      S k => go k init
    where
      go : Nat -> acc -> acc
      go Z       acc = f (xs !! 0) acc
      go i@(S k) acc = go k (f (xs !! i) acc)

  foldl f init xs =
    case length xs of
      Z   => init
      S k => go Z k init
    where
      go : Nat -> Nat -> acc -> acc
      go i Z     acc = f acc (xs !! i)
      go i (S k) acc = go (S i) k (f acc (xs !! i))

Show a => Show (Vector a) where
  show xs = foldl (\acc, e => (if (length acc > 1) then (acc ++ ", ") else acc) ++ show e) "[" xs ++ "]"


{-
Foreign collections
  - FList   : foreign List
  - FVect   : foreign Vector
  - FHVect  : foreign Heterogeneous Vector

If your language supports some of them, just make sure
the relatedc builtins functions should be implemented in
your language, like
  python: `cam-python/idris_cam/rumtime.py'
  julia:  `cam-julia/src/Runtime.jl`
-}

module FCollections
import Data.Vect
import Data.HVect
import Cam.Data.Collections
import Cam.FFI
import Cam.IO

%access public export
%hide Vect.index
%hide HVect.index

-- maybe overflow
%inline
indexRawOF : String -> Int -> Unsafe -> Unsafe
indexRawOF s i v = let builtin = Builtin s in
                   let i = believe_me i in
                   let box = fcall FFun2 builtin i v in
                   believe_me $ unsafePerformIO box

%inline
indexRaw : String -> Integer -> Unsafe -> Unsafe
indexRaw s i v = let builtin = Builtin s in
                 let i = believe_me i in
                 let box = fcall FFun2 builtin i v in
                 believe_me $ unsafePerformIO box

-- using `nat` data structure to index
%inline
indexRawNat : String -> Nat -> Unsafe -> Unsafe
indexRawNat s i v = let builtin = Builtin s in
                    let i = believe_me i in
                    let box = fcall FFun2 builtin i v in
                    believe_me $ unsafePerformIO box

-- Implementations for FList
%inline
sizeFList : FList a -> Integer
sizeFList lst = assert_total $
    let builtin = Builtin "size_flist" in
    let box = fcall FFun1 builtin (believe_me lst) in
    believe_me $ unsafePerformIO box

implementation Sized (FList t) where
 -- It seems that using `size = sizeFlist` causes bad properties, not sure yet
  size lst = fromInteger $ sizeFList lst

implementation Indexable (FList t) Integer where
  eltype {t} _ _ = Boxed t
  index {t} i xs = believe_me e
    where
      src : Unsafe
      src = believe_me xs
      e : Unsafe
      e = indexRaw "index_flist" i src

reverseFList : FList a -> FList a
reverseFList lst = let builtin = Builtin "reverse_flist" in
                   let box = fcall FFun1 builtin (believe_me lst) in
                   believe_me $ unsafePerformIO box

implementation Reversable (FList a) (FList a) where
  reverse = reverseFList

-- Implementations for FVect

sizeFVect : FVect n a -> Nat
sizeFVect {n} _ = n

implementation StaticSized (FVect n a) where
  typeSize {n} _ = n

implementation Sized (FVect n a) where
  size vec = sizeFVect vec

implementation Indexable (FVect n t) (Fin n) where
  eltype {t} _ _ = Boxed t
  index fin vec = believe_me e
    where
      i : Integer
      i = finToInteger fin
      src : Unsafe
      src = believe_me vec
      e : Unsafe
      e = indexRaw "index_fvect" i src

reverseFVect : FVect n a -> FVect n a
reverseFVect {n} vec = let builtin = Builtin "reverse_fvect" in
                       let box = fcall FFun1 builtin $ believe_me vec in
                       believe_me $ unsafePerformIO box

implementation Reversable (FVect n a) (FVect n a) where
  reverse vec = reverseFVect vec

-- Implementations for FHVect

sizeFHVect : {xs: Vect n Type} -> FHVect xs -> Nat
sizeFHVect {n} _ = n

implementation StaticSized (FHVect xs) where
  typeSize {xs} _ = size xs

implementation Sized (FHVect xs) where
  size vec = sizeFHVect vec

-- It's tricky here for there're still some bugs in Idris.
-- related: https://github.com/idris-lang/Idris-dev/issues/3136

implementation Indexable (FHVect xs) (Fin (size xs)) where
  eltype {xs} fin _ = Boxed (index fin xs)
  index fin vec = believe_me e
    where
      i : Integer
      i = finToInteger fin
      src : Unsafe
      src = believe_me vec
      e : Unsafe
      e = indexRaw "index_fhvect" i src

reverseFHVect : FHVect xs -> FHVect (reverseVect xs)
reverseFHVect {xs} vec = let builtin = Builtin "reverse_fvect" in
                         let box = fcall FFun1 builtin $ believe_me vec in
                         believe_me $ unsafePerformIO box

implementation Reversable (FHVect xs) (FHVect (reverseVect xs)) where
  reverse vec = reverseFHVect vec


||| Hashconsing App
|||
||| Copyright 2021, HATTORI, Hiroki
||| This file is released under the MIT license, see LICENSE for more detail.
|||
module Control.App.Hashcons

import Control.App
import Data.So

import Data.Hash
import Data.Hashtable as H

%default total

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

data FreshCounter : Type where
data Cache : Type -> Type where
export data HC t = MkHC (t, Int)

export %inline unintern : HC t -> t
unintern (MkHC (x, _)) = x

Eq (HC t) where MkHC (_, l) == MkHC (_, r) = l == r
Ord t => Ord (HC t) where
  compare (MkHC (l, _)) (MkHC (r, _)) = compare l r
  (MkHC (l, _)) < (MkHC (r, _)) = l > r
  (MkHC (l, _)) > (MkHC (r, _)) = l < r
  (MkHC (l, _)) <= (MkHC (r, _)) = l >= r
  (MkHC (l, _)) >= (MkHC (r, _)) = l <= r

public export
interface Hashcons t es where
  intern : t -> App {l} es (HC t)

public export partial
(Eq t, Hashable t,
 State (Cache t) (Int, IOHashtable t Int) es, PrimIO es)
 => Hashcons t es where
  intern k = do
    (fresh, cache) <- get (Cache t)
    x <- primIO $ H.lookup' k cache
    case x of
         Just x' => pure $ MkHC x'
         Nothing => do
           x' <- primIO $ H.insert' k (fresh + 1) cache
           _ <- put (Cache t) (fresh + 1, cache)
           pure $ MkHC x'

export partial
withHashcons : (Hashcons t es, PrimIO es)
               => (cachesize:Int) -> {auto _:So (cachesize > 0)}
               -> App {l} es a -> App {l} es a
withHashcons cachesize prog = do
  cache <- primIO $ H.newHashtable {k=t} {v=Int} cachesize
  new {tag=Cache t} (0, cache) prog


import Data.Vect

Position : Type
Position = (Double, Double)

Polygon : Nat -> Type
Polygon n = Vect n Position

StringOrInt : Bool -> Type
StringOrInt False = String
StringOrInt True = Int

getStringOrInt : (isInt : Bool) -> StringOrInt isInt
getStringOrInt False = "false"
getStringOrInt True = 1

valToString : (isInt : Bool) -> StringOrInt isInt -> String
valToString False y = ?valToString_rhs_2
valToString True y = ?valToString_rhs_3


module Data.Functor.Tagged

import Data.Profunctor
import Data.Profunctor.Choice

public export
data Tagged : (a : Type) -> (b : Type) -> Type where
  MkTagged : b -> Tagged a b

export
retag : Tagged s b -> Tagged t b
retag (MkTagged b) = MkTagged b

export
untag : Tagged s b -> b
untag (MkTagged b) = b

export
Semigroup b => Semigroup (Tagged a b) where
  MkTagged x <+> MkTagged x' = MkTagged (x <+> x')

export
Monoid b => Monoid (Tagged a b) where
  neutral = MkTagged neutral

export
Functor (Tagged a) where
  map f (MkTagged x) = MkTagged (f x)

export
Applicative (Tagged a) where
  pure = MkTagged
  (MkTagged f) <*> (MkTagged x) = MkTagged (f x)

export
Monad (Tagged a) where
  MkTagged m >>= k = k m

export
Bifunctor Tagged where
  bimap f g (MkTagged b) = MkTagged (g b)

export
Profunctor Tagged where
  lmap _ = retag
  rmap = map

export
Choice Tagged where
  left' (MkTagged b) = MkTagged (Left b)
  right' (MkTagged b) = MkTagged (Right b)