module Sub11Apply108x54

import ProofColDivSeqBase
import ProofColDivSeqPostulate

%default total
-- %language ElabReflection

-- 3(36x+18) --F[5,-2]->C[4,-4]--> 3(32x+15)
fc108x54To96x45 :
  (o:Nat) -> P (S (S (S (S (S (plus (plus (plus (plus (plus (plus o o) o) (S (plus (plus o o) o)))
                                           (S (plus (plus (plus o o) o) (S (plus (plus o o) o)))))
                                     (S (S (plus (plus (plus (plus o o) o) (S (plus (plus o o) o))) (S (plus (plus (plus o o) o) (S (plus (plus o o) o))))))))
                               (S (S (plus (plus (plus (plus o o) o) (S (plus (plus o o) o))) (S (plus (plus (plus o o) o) (S (plus (plus o o) o))))))))))))) 2
    -> P (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (plus (plus (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o))) (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o))))
                                                            (plus (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o))) (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o)))))))))))))))))))) 2
fc108x54To96x45 o prf =
  let prf2 = lvDown (S (S (S (S (S (plus (plus (plus (plus (plus (plus o o) o) (S (plus (plus o o) o)))
                                           (S (plus (plus (plus o o) o) (S (plus (plus o o) o)))))
                                     (S (S (plus (plus (plus (plus o o) o) (S (plus (plus o o) o))) (S (plus (plus (plus o o) o) (S (plus (plus o o) o))))))))
                               (S (S (plus (plus (plus (plus o o) o) (S (plus (plus o o) o))) (S (plus (plus (plus o o) o) (S (plus (plus o o) o))))))))))))) 2
                    prf in
    let prf3 = fc108x54To96x45' o prf2 in lvDown (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (plus (plus (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o))) (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o))))
                                                            (plus (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o))) (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o)))))))))))))))))))) 3 prf3

export
apply108x54 : P (S (S (S (S (S (plus (plus (plus (plus (plus (plus o o) o) (S (plus (plus o o) o)))
                                           (S (plus (plus (plus o o) o) (S (plus (plus o o) o)))))
                                     (S (S (plus (plus (plus (plus o o) o) (S (plus (plus o o) o))) (S (plus (plus (plus o o) o) (S (plus (plus o o) o))))))))
                               (S (S (plus (plus (plus (plus o o) o) (S (plus (plus o o) o))) (S (plus (plus (plus o o) o) (S (plus (plus o o) o))))))))))))) 2
  -> (m : Nat **
        (LTE (S m)
             (S (S (S (S (S (plus (plus (plus (plus (plus (plus o o) o) (S (plus (plus o o) o))) (S (plus (plus (plus o o) o) (S (plus (plus o o) o)))))
                                        (S (S (plus (plus (plus (plus o o) o) (S (plus (plus o o) o))) (S (plus (plus (plus o o) o) (S (plus (plus o o) o))))))))
                                  (S (S (plus (plus (plus (plus o o) o) (S (plus (plus o o) o))) (S (plus (plus (plus o o) o) (S (plus (plus o o) o))))))))))))),
         P m 2))
apply108x54 {o} col = let col2 = fc108x54To96x45 o col in ((S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (plus (plus (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o))) (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o))))
                                                            (plus (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o))) (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o)))))))))))))))))))) ** (lte108x54 o, col2)) where
  lte108x54 : (o:Nat) -> LTE (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (plus (plus (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o)))
                                                                      (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o))))
                                                                (plus (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o)))
                                                                      (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o)))))))))))))))))))))
          (S (S (S (S (S (plus (plus (plus (plus (plus (plus o o) o) (S (plus (plus o o) o))) (S (plus (plus (plus o o) o) (S (plus (plus o o) o)))))
                                     (S (S (plus (plus (plus (plus o o) o) (S (plus (plus o o) o))) (S (plus (plus (plus o o) o) (S (plus (plus o o) o))))))))
                               (S (S (plus (plus (plus (plus o o) o) (S (plus (plus o o) o))) (S (plus (plus (plus o o) o) (S (plus (plus o o) o)))))))))))))
  lte108x54 Z = (lteSuccRight . lteSuccRight . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc) LTEZero
  lte108x54 (S o) = let lemma = lte108x54 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 (plus (plus (plus o o) (plus o o))
                                                                                (plus (plus o o) (plus o o)))
                                                                                (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o))))
                                    (S (S (S (S (S (S (S (S (S (S (S (S (S (S (S (plus (plus (plus (plus o o)
                                                                                (plus o o))
                                                                                (plus (plus o o)
                                                                                (plus o o)))
                                                                                (plus (plus (plus o o)
                                                                                (plus o o))
                                                                                (plus (plus o o)
                                                                                (plus o
                                                                                o))))))))))))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus o o) (plus o o))
                                                                                (plus (plus o o) (plus o o)))
                                                                                (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o))))
                                    (S (S (S (S (S (S (S (S (S (S (S (S (S (S (plus (plus (plus (plus o o)
                                                                                (plus o o))
                                                                                (plus (plus o o)
                                                                                (plus o o)))
                                                                                (plus (plus (plus o o)
                                                                                (plus o o))
                                                                                (plus (plus o o)
                                                                                (plus o
                                                                                o)))))))))))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus o o) (plus o o))
                                                                                (plus (plus o o) (plus o o)))
                                                                                (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o))))
                                    (S (S (S (S (S (S (S (S (S (S (S (S (S (plus (plus (plus (plus o o)
                                                                                (plus o o))
                                                                                (plus (plus o o)
                                                                                (plus o o)))
                                                                                (plus (plus (plus o o)
                                                                                (plus o o))
                                                                                (plus (plus o o)
                                                                                (plus o
                                                                                o))))))))))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus o o) (plus o o))
                                                                                (plus (plus o o) (plus o o)))
                                                                                (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o))))
                                    (S (S (S (S (S (S (S (S (S (S (S (S (plus (plus (plus (plus o o)
                                                                                (plus o o))
                                                                                (plus (plus o o)
                                                                                (plus o o)))
                                                                                (plus (plus (plus o o)
                                                                                (plus o o))
                                                                                (plus (plus o o)
                                                                                (plus o
                                                                                o)))))))))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus o o) (plus o o))
                                                                                (plus (plus o o) (plus o o)))
                                                                                (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o))))
                                    (S (S (S (S (S (S (S (S (S (S (S (plus (plus (plus (plus o o)
                                                                                (plus o o))
                                                                                (plus (plus o o)
                                                                                (plus o o)))
                                                                                (plus (plus (plus o o)
                                                                                (plus o o))
                                                                                (plus (plus o o)
                                                                                (plus o
                                                                                o))))))))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus o o) (plus o o))
                                                                                (plus (plus o o) (plus o o)))
                                                                                (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o))))
                                    (S (S (S (S (S (S (S (S (S (S (plus (plus (plus (plus o o)
                                                                                (plus o o))
                                                                                (plus (plus o o)
                                                                                (plus o o)))
                                                                                (plus (plus (plus o o)
                                                                                (plus o o))
                                                                                (plus (plus o o)
                                                                                (plus o
                                                                                o)))))))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus o o) (plus o o))
                                                                                (plus (plus o o) (plus o o)))
                                                                                (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o))))
                                    (S (S (S (S (S (S (S (S (S (plus (plus (plus (plus o o)
                                                                                (plus o o))
                                                                                (plus (plus o o)
                                                                                (plus o o)))
                                                                                (plus (plus (plus o o)
                                                                                (plus o o))
                                                                                (plus (plus o o)
                                                                                (plus o
                                                                                o))))))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus o o) (plus o o))
                                                                                (plus (plus o o) (plus o o)))
                                                                                (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o))))
                                    (S (S (S (S (S (S (S (S (plus (plus (plus (plus o o)
                                                                                (plus o o))
                                                                                (plus (plus o o)
                                                                                (plus o o)))
                                                                                (plus (plus (plus o o)
                                                                                (plus o o))
                                                                                (plus (plus o o)
                                                                                (plus o
                                                                                o)))))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus o o) (plus o o))
                                                                                (plus (plus o o) (plus o o)))
                                                                                (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o))))
                                    (S (S (S (S (S (S (S (plus (plus (plus (plus o o)
                                                                                (plus o o))
                                                                                (plus (plus o o)
                                                                                (plus o o)))
                                                                                (plus (plus (plus o o)
                                                                                (plus o o))
                                                                                (plus (plus o o)
                                                                                (plus o
                                                                                o))))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus o o) (plus o o))
                                                                                (plus (plus o o) (plus o o)))
                                                                                (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o))))
                                    (S (S (S (S (S (S (plus (plus (plus (plus o o)
                                                                                (plus o o))
                                                                                (plus (plus o o)
                                                                                (plus o o)))
                                                                                (plus (plus (plus o o)
                                                                                (plus o o))
                                                                                (plus (plus o o)
                                                                                (plus o
                                                                                o)))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus o o) (plus o o))
                                                                                (plus (plus o o) (plus o o)))
                                                                                (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o))))
                                    (S (S (S (S (S (plus (plus (plus (plus o o)
                                                                                (plus o o))
                                                                                (plus (plus o o)
                                                                                (plus o o)))
                                                                                (plus (plus (plus o o)
                                                                                (plus o o))
                                                                                (plus (plus o o)
                                                                                (plus o
                                                                                o))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus o o) (plus o o))
                                                                                (plus (plus o o) (plus o o)))
                                                                                (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o))))
                                    (S (S (S (S (plus (plus (plus (plus o o)
                                                                                (plus o o))
                                                                                (plus (plus o o)
                                                                                (plus o o)))
                                                                                (plus (plus (plus o o)
                                                                                (plus o o))
                                                                                (plus (plus o o)
                                                                                (plus o
                                                                                o)))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus o o) (plus o o))
                                                                                (plus (plus o o) (plus o o)))
                                                                                (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o))))
                                    (S (S (S (plus (plus (plus (plus o o)
                                                                                (plus o o))
                                                                                (plus (plus o o)
                                                                                (plus o o)))
                                                                                (plus (plus (plus o o)
                                                                                (plus o o))
                                                                                (plus (plus o o)
                                                                                (plus o
                                                                                o))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus o o) (plus o o))
                                                                                (plus (plus o o) (plus o o)))
                                                                                (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o))))
                                    (S (S (plus (plus (plus (plus o o)
                                                                                (plus o o))
                                                                                (plus (plus o o)
                                                                                (plus o o)))
                                                                                (plus (plus (plus o o)
                                                                                (plus o o))
                                                                                (plus (plus o o)
                                                                                (plus o
                                                                                o)))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus o o) (plus o o))
                                                                                (plus (plus o o) (plus o o)))
                                                                                (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o))))
                                    (S (plus (plus (plus (plus o o)
                                                                                (plus o o))
                                                                                (plus (plus o o)
                                                                                (plus o o)))
                                                                                (plus (plus (plus o o)
                                                                                (plus o o))
                                                                                (plus (plus o o)
                                                                                (plus o
                                                                                o))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus o o) (plus o o))
                                                                                (plus (plus o o) (plus o o)))
                                                                                (plus (plus (plus o o) (plus o o)) (plus (plus o o) (plus o o))))
                                    (plus (plus (plus (plus o o)
                                                                                (plus o o))
                                                                                (plus (plus o o)
                                                                                (plus o o)))
                                                                                (plus (plus (plus o o)
                                                                                (plus o o))
                                                                                (plus (plus o o)
                                                                                (plus o
                                                                                o)))))) in

    rewrite (sym (plusSuccRightSucc (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 o o) o)  (S (plus (plus o o) o)))) in

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

    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus o o) o) (S (plus (plus o o) o)))
                                                                               (S (plus (plus (plus o o) o) (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 (plus (plus o o) o)))
                                                                                (S (plus (plus (plus o o) o)
                                            (S (plus (plus o o) o)))))))))))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus o o) o) (S (plus (plus o o) o)))
                                                                               (S (plus (plus (plus o o) o) (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 (plus (plus o o) o)))
                                                                                (S (plus (plus (plus o o) o)
                                            (S (plus (plus o o) o))))))))))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus o o) o) (S (plus (plus o o) o)))
                                                                               (S (plus (plus (plus o o) o) (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 (plus (plus o o) o)))
                                                                                (S (plus (plus (plus o o) o)
                                            (S (plus (plus o o) o)))))))))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus o o) o) (S (plus (plus o o) o)))
                                                                               (S (plus (plus (plus o o) o) (S (plus (plus o o) o)))))
                                    (S (S (S (S (S (S (S (S (S (S (plus (plus (plus (plus o o) o) (S (plus (plus o o) o)))
                                                                                (S (plus (plus (plus o o) o)
                                            (S (plus (plus o o) o))))))))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus o o) o) (S (plus (plus o o) o)))
                                                                               (S (plus (plus (plus o o) o) (S (plus (plus o o) o)))))
                                    (S (S (S (S (S (S (S (S (S (plus (plus (plus (plus o o) o) (S (plus (plus o o) o)))
                                                                                (S (plus (plus (plus o o) o)
                                            (S (plus (plus o o) o)))))))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus o o) o) (S (plus (plus o o) o)))
                                                                               (S (plus (plus (plus o o) o) (S (plus (plus o o) o)))))
                                    (S (S (S (S (S (S (S (S (plus (plus (plus (plus o o) o) (S (plus (plus o o) o)))
                                                                                (S (plus (plus (plus o o) o)
                                            (S (plus (plus o o) o))))))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus o o) o) (S (plus (plus o o) o)))
                                                                               (S (plus (plus (plus o o) o) (S (plus (plus o o) o)))))
                                    (S (S (S (S (S (S (S (plus (plus (plus (plus o o) o) (S (plus (plus o o) o)))
                                                                                (S (plus (plus (plus o o) o)
                                            (S (plus (plus o o) o)))))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus o o) o) (S (plus (plus o o) o)))
                                                                               (S (plus (plus (plus o o) o) (S (plus (plus o o) o)))))
                                    (S (S (S (S (S (S (plus (plus (plus (plus o o) o) (S (plus (plus o o) o)))
                                                                                (S (plus (plus (plus o o) o)
                                            (S (plus (plus o o) o))))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus o o) o) (S (plus (plus o o) o)))
                                                                               (S (plus (plus (plus o o) o) (S (plus (plus o o) o)))))
                                    (S (S (S (S (S (plus (plus (plus (plus o o) o) (S (plus (plus o o) o)))
                                                                                (S (plus (plus (plus o o) o)
                                            (S (plus (plus o o) o)))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus o o) o) (S (plus (plus o o) o)))
                                                                               (S (plus (plus (plus o o) o) (S (plus (plus o o) o)))))
                                    (S (S (S (S (plus (plus (plus (plus o o) o) (S (plus (plus o o) o)))
                                                                                (S (plus (plus (plus o o) o)
                                            (S (plus (plus o o) o))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus o o) o) (S (plus (plus o o) o)))
                                                                               (S (plus (plus (plus o o) o) (S (plus (plus o o) o)))))
                                    (S (S (S (plus (plus (plus (plus o o) o) (S (plus (plus o o) o)))
                                                                                (S (plus (plus (plus o o) o)
                                            (S (plus (plus o o) o)))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus o o) o) (S (plus (plus o o) o)))
                                                                               (S (plus (plus (plus o o) o) (S (plus (plus o o) o)))))
                                    (S (S (plus (plus (plus (plus o o) o) (S (plus (plus o o) o)))
                                                                                (S (plus (plus (plus o o) o)
                                            (S (plus (plus o o) o))))))))) in

    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus (plus o o) o)
                                                                                (S (plus (plus o o) o)))
                                                                                (S (plus (plus (plus o o) o) (S (plus (plus o o) o)))))
                                                                                (S (S (plus (plus (plus (plus o o) o) (S (plus (plus o o) o)))
                                                                                (S (plus (plus (plus o o) o) (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 (plus (plus o o) o)))
                                                                                (S (plus (plus (plus o o) o)
                                                                                (S (plus (plus o o)
                                          o)))))))))))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus (plus o o) o)
                                                                                (S (plus (plus o o) o)))
                                                                                (S (plus (plus (plus o o) o) (S (plus (plus o o) o)))))
                                                                                (S (S (plus (plus (plus (plus o o) o) (S (plus (plus o o) o)))
                                                                                (S (plus (plus (plus o o) o) (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 (plus (plus o o) o)))
                                                                                (S (plus (plus (plus o o) o)
                                                                                (S (plus (plus o o)
                                          o))))))))))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus (plus o o) o)
                                                                                (S (plus (plus o o) o)))
                                                                                (S (plus (plus (plus o o) o) (S (plus (plus o o) o)))))
                                                                                (S (S (plus (plus (plus (plus o o) o) (S (plus (plus o o) o)))
                                                                                (S (plus (plus (plus o o) o) (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 (plus (plus o o) o)))
                                                                                (S (plus (plus (plus o o) o)
                                                                                (S (plus (plus o o)
                                          o)))))))))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus (plus o o) o)
                                                                                (S (plus (plus o o) o)))
                                                                                (S (plus (plus (plus o o) o) (S (plus (plus o o) o)))))
                                                                                (S (S (plus (plus (plus (plus o o) o) (S (plus (plus o o) o)))
                                                                                (S (plus (plus (plus o o) o) (S (plus (plus o o) o))))))))
                                    (S (S (S (S (S (S (S (S (S (S (plus (plus (plus (plus o o) o)
                                                                                (S (plus (plus o o) o)))
                                                                                (S (plus (plus (plus o o) o)
                                                                                (S (plus (plus o o)
                                          o))))))))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus (plus o o) o)
                                                                                (S (plus (plus o o) o)))
                                                                                (S (plus (plus (plus o o) o) (S (plus (plus o o) o)))))
                                                                                (S (S (plus (plus (plus (plus o o) o) (S (plus (plus o o) o)))
                                                                                (S (plus (plus (plus o o) o) (S (plus (plus o o) o))))))))
                                    (S (S (S (S (S (S (S (S (S (plus (plus (plus (plus o o) o)
                                                                                (S (plus (plus o o) o)))
                                                                                (S (plus (plus (plus o o) o)
                                                                                (S (plus (plus o o)
                                          o)))))))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus (plus o o) o)
                                                                                (S (plus (plus o o) o)))
                                                                                (S (plus (plus (plus o o) o) (S (plus (plus o o) o)))))
                                                                                (S (S (plus (plus (plus (plus o o) o) (S (plus (plus o o) o)))
                                                                                (S (plus (plus (plus o o) o) (S (plus (plus o o) o))))))))
                                    (S (S (S (S (S (S (S (S (plus (plus (plus (plus o o) o)
                                                                                (S (plus (plus o o) o)))
                                                                                (S (plus (plus (plus o o) o)
                                                                                (S (plus (plus o o)
                                          o))))))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus (plus o o) o)
                                                                                (S (plus (plus o o) o)))
                                                                                (S (plus (plus (plus o o) o) (S (plus (plus o o) o)))))
                                                                                (S (S (plus (plus (plus (plus o o) o) (S (plus (plus o o) o)))
                                                                                (S (plus (plus (plus o o) o) (S (plus (plus o o) o))))))))
                                    (S (S (S (S (S (S (S (plus (plus (plus (plus o o) o)
                                                                                (S (plus (plus o o) o)))
                                                                                (S (plus (plus (plus o o) o)
                                                                                (S (plus (plus o o)
                                          o)))))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus (plus o o) o)
                                                                                (S (plus (plus o o) o)))
                                                                                (S (plus (plus (plus o o) o) (S (plus (plus o o) o)))))
                                                                                (S (S (plus (plus (plus (plus o o) o) (S (plus (plus o o) o)))
                                                                                (S (plus (plus (plus o o) o) (S (plus (plus o o) o))))))))
                                    (S (S (S (S (S (S (plus (plus (plus (plus o o) o)
                                                                                (S (plus (plus o o) o)))
                                                                                (S (plus (plus (plus o o) o)
                                                                                (S (plus (plus o o)
                                          o))))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus (plus o o) o)
                                                                                (S (plus (plus o o) o)))
                                                                                (S (plus (plus (plus o o) o) (S (plus (plus o o) o)))))
                                                                                (S (S (plus (plus (plus (plus o o) o) (S (plus (plus o o) o)))
                                                                                (S (plus (plus (plus o o) o) (S (plus (plus o o) o))))))))
                                    (S (S (S (S (S (plus (plus (plus (plus o o) o)
                                                                                (S (plus (plus o o) o)))
                                                                                (S (plus (plus (plus o o) o)
                                                                                (S (plus (plus o o)
                                          o)))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus (plus o o) o)
                                                                                (S (plus (plus o o) o)))
                                                                                (S (plus (plus (plus o o) o) (S (plus (plus o o) o)))))
                                                                                (S (S (plus (plus (plus (plus o o) o) (S (plus (plus o o) o)))
                                                                                (S (plus (plus (plus o o) o) (S (plus (plus o o) o))))))))
                                    (S (S (S (S (plus (plus (plus (plus o o) o)
                                                                                (S (plus (plus o o) o)))
                                                                                (S (plus (plus (plus o o) o)
                                                                                (S (plus (plus o o)
                                          o))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus (plus o o) o)
                                                                                (S (plus (plus o o) o)))
                                                                                (S (plus (plus (plus o o) o) (S (plus (plus o o) o)))))
                                                                                (S (S (plus (plus (plus (plus o o) o) (S (plus (plus o o) o)))
                                                                                (S (plus (plus (plus o o) o) (S (plus (plus o o) o))))))))
                                    (S (S (S (plus (plus (plus (plus o o) o)
                                                                                (S (plus (plus o o) o)))
                                                                                (S (plus (plus (plus o o) o)
                                                                                (S (plus (plus o o)
                                          o)))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus (plus o o) o)
                                                                                (S (plus (plus o o) o)))
                                                                                (S (plus (plus (plus o o) o) (S (plus (plus o o) o)))))
                                                                                (S (S (plus (plus (plus (plus o o) o) (S (plus (plus o o) o)))
                                                                                (S (plus (plus (plus o o) o) (S (plus (plus o o) o))))))))
                                    (S (S (plus (plus (plus (plus o o) o)
                                                                                (S (plus (plus o o) o)))
                                                                                (S (plus (plus (plus o o) o)
                                                                                (S (plus (plus o o)
                                          o))))))))) in
      (lteSuccRight . lteSuccRight . lteSuccRight . lteSuccRight . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc) lemma


-- exercises in "Type-Driven Development with Idris"
-- chapter 12, section 3

-- check that all functions are total
%default total

record Votes where
  constructor MkVotes
  upvotes : Integer
  downvotes : Integer

record Article where
  constructor MkArticle
  title : String
  url : String
  score : Votes

initPage : (title : String) -> (url : String) -> Article
initPage title url = MkArticle title url (MkVotes 0 0)

getScore : Article -> Integer
getScore a = let s = score a in (upvotes s) - (downvotes s)

badSite : Article
badSite = MkArticle "Bad Page" "http://example.com/bad" $ MkVotes 5 47

goodSite : Article
goodSite = MkArticle "Good Page" "http://example.com/good" $ MkVotes 101 7

addUpVote : Article -> Article
addUpVote = record { score->upvotes $= (+1) }

addDownVote : Article -> Article
addDownVote = record { score->downvotes $= (+1) }


module Data.Either

import public Control.Function
import Data.List1

%default total

--------------------------------------------------------------------------------
-- Checking for a specific constructor

||| Extract the Left value, if possible
public export
getLeft : Either a b -> Maybe a
getLeft (Left a) = Just a
getLeft _ = Nothing

||| Extract the Right value, if possible
public export
getRight : Either a b -> Maybe b
getRight (Right b) = Just b
getRight _ = Nothing

||| True if the argument is Left, False otherwise
public export
isLeft : Either a b -> Bool
isLeft (Left _)  = True
isLeft (Right _) = False

||| True if the argument is Right, False otherwise
public export
isRight : Either a b -> Bool
isRight (Left _)  = False
isRight (Right _) = True

||| Proof that an `Either` is actually a Right value
public export
data IsRight : Either a b -> Type where
  ItIsRight : IsRight (Right x)

export
Uninhabited (IsRight (Left x)) where
  uninhabited ItIsRight impossible

||| Proof that an `Either` is actually a Left value
public export
data IsLeft : Either a b -> Type where
  ItIsLeft : IsLeft (Left x)

export
Uninhabited (IsLeft (Right x)) where
  uninhabited ItIsLeft impossible

--------------------------------------------------------------------------------
-- Grouping values

||| Compress the list of Lefts and Rights by accumulating
||| all of the lefts and rights into non-empty blocks.
export
compress : List (Either a b) -> List (Either (List1 a) (List1 b))
compress [] = []
compress (Left x :: abs) = compressLefts (singleton x) abs where
  compressLefts : List1 a -> List (Either a b) -> List (Either (List1 a) (List1 b))
  compressLefts acc (Left a :: abs) = compressLefts (cons a acc) abs
  compressLefts acc abs = Left (reverse acc) :: compress abs
compress (Right y :: abs) = compressRights (singleton y) abs where
  compressRights : List1 b -> List (Either a b) -> List (Either (List1 a) (List1 b))
  compressRights acc (Right b :: abs) = compressRights (cons b acc) abs
  compressRights acc abs = Right (reverse acc) :: compress abs

||| Decompress a compressed list. This is the left inverse of `compress` but not its
||| right inverse because nothing forces the input to be maximally compressed!
export
decompress : List (Either (List1 a) (List1 b)) -> List (Either a b)
decompress = concatMap $ \case
  Left  as => map Left  $ forget as
  Right bs => map Right $ forget bs

||| Keep the payloads of all Left constructors in a list of Eithers
public export
lefts : List (Either a b) -> List a
lefts []              = []
lefts (Left  l :: xs) = l :: lefts xs
lefts (Right _ :: xs) = lefts xs

||| Keep the payloads of all Right constructors in a list of Eithers
public export
rights : List (Either a b) -> List b
rights []              = []
rights (Left  _ :: xs) = rights xs
rights (Right r :: xs) = r :: rights xs

||| Split a list of Eithers into a list of the left elements and a list of the right elements
public export
partitionEithers : List (Either a b) -> (List a, List b)
partitionEithers l = (lefts l, rights l)

||| Remove a "useless" Either by collapsing the case distinction
public export
fromEither : Either a a -> a
fromEither (Left l)  = l
fromEither (Right r) = r

||| Right becomes left and left becomes right
public export
mirror : Either a b -> Either b a
mirror (Left  x) = Right x
mirror (Right x) = Left x

--------------------------------------------------------------------------------
-- Bifunctor

export
pushInto : c -> Either a b -> Either (c, a) (c, b)
pushInto c = bimap (\ a => (c, a)) (\ b => (c, b))
  -- ^ not using sections to keep it backwards compatible

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

||| Convert a Maybe to an Either by using a default value in case of Nothing
||| @ e the default value
public export
maybeToEither : (def : Lazy e) -> Maybe a -> Either e a
maybeToEither def (Just j) = Right j
maybeToEither def Nothing  = Left  def

||| Convert an Either to a Maybe from Right injection
public export
eitherToMaybe : Either e a -> Maybe a
eitherToMaybe (Left _) = Nothing
eitherToMaybe (Right x) = Just x

export
eitherMapFusion : (f : _) -> (g : _) -> (p : _) -> (e : Either a b) -> either f g (map p e) = either f (g . p) e
eitherMapFusion f g p $ Left x  = Refl
eitherMapFusion f g p $ Right x = Refl

export
eitherBimapFusion : (f : _) -> (g : _) -> (p : _) -> (q : _) -> (e : _) -> either f g (bimap p q e) = either (f . p) (g . q) e
eitherBimapFusion f g p q $ Left z  = Refl
eitherBimapFusion f g p q $ Right z = Refl

-- Injectivity of constructors

||| Left is injective
export
Injective Left where
  injective Refl = Refl

||| Right is injective
export
Injective Right where
  injective Refl = Refl


module EquivExercises

import Equiv
import Expr
import Imp
import Inequiv
import Logic
import Maps

%access public export

%default total

noninterfering_update : Not (l1 = l2) ->
                        VarNotUsedInAExp l1 a2 ->
                        VarNotUsedInAExp l2 a1 ->
                        aeval st a1 = n1 ->
                        ((aeval (t_update l1 n1 st) a2 = n2) ↔ aeval st a2 = n2)
noninterfering_update _ (VNUNum _) _ _ = (id, id)
noninterfering_update _ (VNUId y contra) _ _ =
  rewrite snd (beq_id_false_iff {x=l1} {y=y}) contra
  in (id, id)
noninterfering_update {st} contra (VNUPlus _ _ l1nua3 l1nua4) l2nua1 prf1 =
  let ih1 = noninterfering_update {st=st} contra l1nua3 l2nua1 prf1
      ih2 = noninterfering_update {st=st} contra l1nua4 l2nua1 prf1
  in ( \prf2 => rewrite fst ih1 Refl
                in rewrite fst ih2 Refl
                in prf2
     , \prf2 => rewrite sym $ fst ih1 Refl
                in rewrite sym $ fst ih2 Refl
                in prf2 )
noninterfering_update {st} contra (VNUMinus _ _ l1nua3 l1nua4) l2nua1 prf1 =
  let ih1 = noninterfering_update {st=st} contra l1nua3 l2nua1 prf1
      ih2 = noninterfering_update {st=st} contra l1nua4 l2nua1 prf1
  in ( \prf2 => rewrite fst ih1 Refl
                in rewrite fst ih2 Refl
                in prf2
     , \prf2 => rewrite sym $ fst ih1 Refl
                in rewrite sym $ fst ih2 Refl
                in prf2 )
noninterfering_update {st} contra (VNUMult _ _ l1nua3 l1nua4) l2nua1 prf1 =
  let ih1 = noninterfering_update {st=st} contra l1nua3 l2nua1 prf1
      ih2 = noninterfering_update {st=st} contra l1nua4 l2nua1 prf1
  in ( \prf2 => rewrite fst ih1 Refl
                in rewrite fst ih2 Refl
                in prf2
     , \prf2 => rewrite sym $ fst ih1 Refl
                in rewrite sym $ fst ih2 Refl
                in prf2 )

swap_noninterfering_assignments : Not (l1 = l2) ->
                                  VarNotUsedInAExp l1 a2 ->
                                  VarNotUsedInAExp l2 a1 ->
                                  CEquiv (do l1 ::= a1; l2 ::= a2)
                                         (do l2 ::= a2; l1 ::= a1)
swap_noninterfering_assignments {l1} {l2} {a1} {a2} contra l1nua2 l2nua1 st st' =
  (forward, backward)
where forward : ((do l1 ::= a1; l2 ::= a2) / st \\ st') ->
                ((do l2 ::= a2; l1 ::= a1) / st \\ st')
      forward rel = case rel of
        E_Seq (E_Ass {n=n1} prf1) (E_Ass {n=n2} prf2) =>
          let pf1 = fst (noninterfering_update {st=st} contra l1nua2 l2nua1 prf1)
                        prf2
              pf2 = snd (noninterfering_update {st=st}
                                               (neqSym contra) l2nua1 l1nua2 pf1)
                        prf1
          in rewrite t_update_permute contra {v1=n2} {v2=n1} {m=st}
          in E_Seq (E_Ass pf1) (E_Ass pf2)
      backward : ((do l2 ::= a2; l1 ::= a1) / st \\ st') ->
                 ((do l1 ::= a1; l2 ::= a2) / st \\ st')
      backward rel = case rel of
        E_Seq (E_Ass {n=n1} prf1) (E_Ass {n=n2} prf2) =>
          let pf1 = fst (noninterfering_update
                           {st=st} (neqSym contra) l2nua1 l1nua2 prf1)
                        prf2
              pf2 = snd (noninterfering_update {st=st} contra l1nua2 l2nua1 pf1)
                        prf1
          in rewrite sym $ t_update_permute contra {v1=n1} {v2=n2} {m=st}
          in E_Seq (E_Ass pf1) (E_Ass pf2)

CApprox : (c1, c2 : Com) -> Type
CApprox c1 c2 = (st, st' : State) -> (c1 / st \\ st') -> (c2 / st \\ st')

c1 : Com
c1 = WHILE (not (X == 1)) $
       X ::= X - 1

c2 : Com
c2 = X ::= 1

c3 : Com
c3 = c2

c4 : Com
c4 = X ::= 2

c3_c4_different : ( Not (CApprox EquivExercises.c3 EquivExercises.c4)
                  , Not (CApprox EquivExercises.c4 EquivExercises.c3) )
c3_c4_different = (forward, backward)
where forward : Not ((st, st' : State) ->
                     (EquivExercises.c3 / st \\ st') ->
                     (EquivExercises.c4 / st \\ st'))
      forward f = case f empty_state (t_update X 1 empty_state) (E_Ass Refl) of
        E_Skip impossible
        (E_Ass _) impossible
        (E_Seq _ _) impossible
        (E_IfTrue _ _) impossible
        (E_IfFalse _ _) impossible
        (E_WhileEnd _) impossible
        (E_WhileLoop _ _ _) impossible
      backward : Not ((st, st' : State) ->
                      (EquivExercises.c4 / st \\ st') ->
                      (EquivExercises.c3 / st \\ st'))
      backward f = case f empty_state (t_update X 2 empty_state) (E_Ass Refl) of
        E_Skip impossible
        (E_Ass _) impossible
        (E_Seq _ _) impossible
        (E_IfTrue _ _) impossible
        (E_IfFalse _ _) impossible
        (E_WhileEnd _) impossible
        (E_WhileLoop _ _ _) impossible

cmin : Com
cmin = WHILE BTrue SKIP

cmin_minimal : (c : Com) -> CApprox EquivExercises.cmin c
cmin_minimal _ _ _ rel = absurd $ while_true_nonterm btrue_is_true rel


data MyShow : Type -> Type where
     ShowImplementation : (show : a -> String) -> MyShow a

myshow : {auto inst : MyShow a} -> a -> String
myshow {inst = ShowImplementation show} x1 = show x1

%hint
showNat : MyShow Nat
showNat = ShowImplementation show

%hint
showFn : MyShow (a -> b)
showFn = ShowImplementation (\x => "<< function >>")

%hint
showBools : MyShow (Bool, Bool)
showBools = ShowImplementation (\x => "some bools")

%hint
showStuff : MyShow a -> MyShow b -> MyShow (a, b)
showStuff sa sb = ShowImplementation showPair
  where
    showPair : (a, b) -> String
    showPair (x, y) = myshow x ++ ", " ++ myshow y

testShow : List (Bool, Bool) -> String
testShow [] = ""
testShow (x :: xs) = myshow x ++ "\n" ++ testShow xs

testShow2 : List (Nat, Int -> Int) -> String
testShow2 [] = ""
testShow2 (x :: xs) = myshow x ++ "\n" ++ testShow2 xs

main : IO ()
main = do putStrLn $ testShow2 [(2, (+1)), (3, abs)]
          putStrLn $ testShow [(True, False), (False, True)]


-- ------------------------------------------------------- [ StateMachines.idr ]
-- Module      : Chapter.StateMachines
-- Description : Definitions from Chapter 13 of Edwin Brady's book,
--               "Type-Driven Development with Idris."
-- --------------------------------------------------------------------- [ EOH ]
module Chapter.StateMachines

import public Control.Monad.State

-- NOTE: See 13.2.1
import Data.Vect

-- ------------------------------------------------- [ 13.1.1 Modelling a Door ]

namespace BadDoor

  public export
  data DoorCmd : Type -> Type where
       Open : DoorCmd ()
       Close : DoorCmd ()
       RingBell : DoorCmd ()

       Pure : ty -> DoorCmd ty
       (>>=) : DoorCmd a -> (a -> DoorCmd b) -> DoorCmd b

  export
  doorProg : DoorCmd ()
  doorProg = do RingBell
                Open
                Close

  doorProgBad : DoorCmd ()
  doorProgBad = do Open
                   Open
                   RingBell

namespace Door

  ||| A door is either open or closed.
  public export
  data DoorState = ||| The door is closed.
                   DoorClosed
                 | ||| The door is open.
                   DoorOpen

  ||| A sequence of door actions which produces a value of type `ty`, begins with
  ||| the door in the state `beforeState`, and ends with the door in the state
  ||| `afterState`.
  ||| @ ty The type of the produced value.
  ||| @ beforeState The initial door state.
  ||| @ afterState The resulting door state.
  public export
  data DoorCmd  : (ty : Type) ->
                  (beforeState, afterState : DoorState) ->
                  Type where

       ||| Open a closed door.
       Open     : DoorCmd () DoorClosed DoorOpen

       ||| Close an open door.
       Close    : DoorCmd () DoorOpen   DoorClosed

       ||| Ring the bell of a closed door.
       RingBell : DoorCmd () state state -- NOTE: Exercise 13.1.5.1

       ||| Lift a value.
       Pure : ty -> DoorCmd ty state state

       ||| Sequentially compose two door actions, passing any value produced by
       ||| the first as an argument to the second.
       (>>=) : DoorCmd a state1 state2 ->
               (a -> DoorCmd b state2 state3) ->
               DoorCmd b state1 state3

  ||| Starting with a closed door, ring the bell, open the door, ring the bell,
  ||| and close the door, resulting in a closed door and producing ().
  export
  doorProg : DoorCmd () DoorClosed DoorClosed
  doorProg = do RingBell
                Open
                RingBell
                Close

-- -------------------------------------- [ 13.1.3 Modelling a Vending Machine ]

namespace VendingMachine

  export
  VendState : Type
  VendState = (Nat, Nat)

  public export
  data Input = COIN
             | VEND
             | CHANGE
             | REFILL Nat

  public export
  data MachineCmd : (ty : Type) ->
                    (beforeState, afterState : VendState) ->
                    Type where

       InsertCoin : MachineCmd () (  pounds,   chocs) (S pounds, chocs)

       Vend       : MachineCmd () (S pounds, S chocs) (  pounds, chocs)

       GetCoins   : MachineCmd () (  pounds,   chocs) (  Z,      chocs)

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

       Display : String -> MachineCmd () state state

       GetInput : MachineCmd (Maybe Input) state state

       ||| Lift a value.
       Pure : ty -> MachineCmd ty state state

       (>>=) : MachineCmd a state1 state2 ->
               (a -> MachineCmd b state2 state3) ->
               MachineCmd b state1 state3

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

namespace MachineDo

  public export
  (>>=) : MachineCmd a state1 state2 ->
          (a -> Inf (MachineIO state2)) -> MachineIO state1
  (>>=) = Do

-- --------------------------------------- [ 13.1.4 A Verified Vending Machine ]

mutual

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

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

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

-- ------------------------------------------------- [ 13.2.1 Stack Operations ]

namespace StackOperations

 public export
 data StackCmd : (ty : Type) ->
                 (a : Type) ->
                 (inHeight, outHeight : Nat) ->
                 Type where

      Push : a -> StackCmd () a height (S height)

      Pop : StackCmd a a (S height) height

      Top : StackCmd a a (S height) (S height)

      GetStr : StackCmd String a height height

      PutStr : String -> StackCmd () a height height

      Pure : ty -> StackCmd ty a height height
      (>>=) : StackCmd a elem height1 height2 ->
              (a -> StackCmd b elem height2 height3) ->
              StackCmd b elem height1 height3

-- export
testAdd : StackCmd Integer Integer 0 0
testAdd = do Push 10
             Push 20
             val1 <- Pop
             val2 <- Pop
             Pure (val1 + val2)

-- NOTE: This will not type check.
-- testAdd : StackCmd Integer 0 0
-- testAdd = do Push 10
--              val1 <- Pop
--              val2 <- Pop
--              Pure (val1 + val2)

-- ------------------------------------------- [ 13.2.2 Implementing the Stack ]

runStack : (stk : Vect inHeight a) ->
           StackCmd ty a inHeight outHeight ->
           IO (ty, Vect outHeight a)
runStack stk (Push val)   = pure ((), val :: stk)
runStack (val :: stk) Pop = pure (val, stk)
runStack (val :: stk) Top = pure (val, val :: stk)
runStack stk GetStr       = do x <- getLine
                               pure (x, stk)
runStack stk (PutStr x)   = putStr x *> pure ((), stk)
runStack stk (Pure x)     = pure (x, stk)
runStack stk (x >>= f)    = do (x', newStk) <- runStack stk x
                               runStack newStk (f x')

printResult : StackCmd () Integer (S height) (S height)
printResult = do result <- Top
                 PutStr (show result ++ "\n")

doBinOp : (op : Integer -> Integer -> Integer) ->
          StackCmd () Integer (S (S height)) (S height)
doBinOp op = do val1 <- Pop
                val2 <- Pop
                -- NOTE: The arguments are ordered this way because subtraction
                -- is not commutative, while addition and multiplication are,
                -- e.g. given 2 <RET> 1 <RET> - <RET>, stackCalc should print 1,
                -- i.e. 2 - 1 = 1, as opposed to 1 - 2 = -1.
                Push (val2 `op` val1)
                printResult

public export
data StackIO : Nat -> Type -> Type where
     Do : StackCmd ty a inHeight outHeight ->
          (ty -> Inf (StackIO outHeight a)) ->
          StackIO inHeight a

namespace StackDo

  (>>=) : StackCmd ty a inHeight outHeight ->
          (ty -> Inf (StackIO outHeight a)) ->
          StackIO inHeight a
  (>>=) = Do

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

partial
forever : Fuel
forever = More forever

export
run : Fuel -> Vect height a -> StackIO height a -> IO ()
run (More fuel) stk (Do c f) = do (res, newStk) <- runStack stk c
                                  run fuel newStk (f res)
run Dry _ _                  = pure ()

public export
data StkInput = Number Integer
              | Add
              -- NOTE: Exercise 13.2.4.1
              | Subtract
              | Multiply
              -- NOTE: Exercise 13.2.4.2
              | Negate
              -- NOTE: Exercise 13.2.4.3
              | Discard
              -- NOTE: Exercise 13.2.4.4
              | Duplicate

export
strToInput : String -> Maybe StkInput
strToInput ""          = Nothing
strToInput "add"       = Just Add
strToInput "subtract"  = Just Subtract
strToInput "multiply"  = Just Multiply
strToInput "negate"    = Just Negate
strToInput "discard"   = Just Discard
strToInput "duplicate" = Just Duplicate
strToInput x           = if all isDigit (unpack x)
                            then Just (Number (cast x))
                            else Nothing

mutual

  tryBinOp : (op : Integer -> Integer -> Integer) -> StackIO height Integer
  tryBinOp {height = S (S _)} op =
      do doBinOp op
         stackCalc
  tryBinOp _ =
      do PutStr "Fewer than two items on the stack\n"
         stackCalc

  tryAdd : StackIO height Integer
  tryAdd = tryBinOp (+)

-- ------------------------------------------------------- [ Exercise 13.2.4.1 ]

  trySubtract : StackIO height Integer
  trySubtract = tryBinOp (-)

  tryMultiply : StackIO height Integer
  tryMultiply = tryBinOp (*)

-- -------------------------------------------------- [ Unary operation helper ]

  emptyStack : StackIO height Integer
  emptyStack = do PutStr "Stack is empty\n"
                  stackCalc

-- ------------------------------------------------------- [ Exercise 13.4.2.2 ]

  tryNegate : StackIO height Integer
  tryNegate {height = S _} = do Push (negate !Pop)
                                printResult
                                stackCalc
  tryNegate                = emptyStack

-- ------------------------------------------------------- [ Exercise 13.4.2.3 ]

  tryDiscard : StackIO height Integer
  tryDiscard {height = S _} = do PutStr $ "Discarded " ++ show !Pop ++ "\n"
                                 stackCalc
  tryDiscard                = emptyStack

-- ------------------------------------------------------- [ Exercise 13.4.2.4 ]

  tryDuplicate : StackIO height Integer
  tryDuplicate {height = S _} = do val <- Top
                                   Push val
                                   PutStr $ "Duplicated " ++ show val ++ "\n"
                                   stackCalc
  tryDuplicate                = emptyStack

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

  export
  stackCalc : StackIO height Integer
  stackCalc = do PutStr "> "
                 input <- GetStr
                 case strToInput input of
                      Nothing         => do PutStr "Invalid input\n"
                                            stackCalc
                      Just (Number x) => do Push x
                                            stackCalc
                      Just Add        => tryAdd
                      -- NOTE: Exercise 13.2.4.1
                      Just Subtract   => trySubtract
                      Just Multiply   => tryMultiply
                      -- NOTE: Exercise 13.2.4.2
                      Just Negate     => tryNegate
                      -- NOTE: Exercise 13.2.4.3
                      Just Discard    => tryDiscard
                      -- NOTE: Exercise 13.2.4.4
                      Just Duplicate  => tryDuplicate

namespace StackCalculator

  export
  partial
  main : IO ()
  main = run forever [] stackCalc

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


-- exercises in "Type-Driven Development with Idris"
-- chapter 14, section 2, VendingMachine part

import System
import Data.Primitives.Views

-- check that all functions are total
%default total

VendState : Type
VendState = (Nat, Nat)

data Input = COIN
           | VEND
           | CHANGE
           | REFILL Nat

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

data CoinResult = Inserted | Rejected

data MachineCmd : (ty : Type) ->
                  VendState ->
                  (ty -> VendState) ->
                  Type where
  InsertCoin : MachineCmd CoinResult (pounds, chocs)
                                     (\res => case res of
                                                Inserted => (S pounds, chocs)
                                                Rejected => (pounds, chocs))
  Vend :       MachineCmd () (S pounds, S chocs) $ const (pounds, chocs)
  GetCoins :   MachineCmd () (pounds, chocs)     $ const (Z, chocs)
  Refill :     (bars : Nat) ->
               MachineCmd () (Z, chocs)          $ const (Z, bars + chocs)
  Display :    String ->
               MachineCmd () s                   $ const s
  GetInput :   MachineCmd (Maybe Input) s        $ const s
  Pure :       (res : ty) -> MachineCmd ty (s res) s
  (>>=) :      MachineCmd a s1                     s2 ->
               ((res : a) -> MachineCmd b (s2 res) s3) ->
               MachineCmd b s1                     s3

data MachineIO : VendState -> Type where
  Do : MachineCmd a s1 s2 ->
       ((res : a) -> Inf (MachineIO (s2 res))) -> MachineIO s1

namespace MachineDo
  (>>=) : MachineCmd a s1 s2 ->
          ((res : a) -> Inf (MachineIO (s2 res))) -> MachineIO s1
  (>>=) = Do

getRandom : Int -> Int -> Int
getRandom val max with (divides val max)
  getRandom val 0 | DivByZero = 0
  getRandom ((max * div) + rem) max | (DivBy prf) = abs rem

||| "randomly generates" a valid or invalid coin
randomCoin : IO CoinResult
randomCoin = do seed <- time
                case (getRandom (fromInteger seed) 4) of
                  0 => pure Rejected
                  _ => pure Inserted

runMachine : MachineCmd ty inState outState -> IO ty
runMachine InsertCoin = do Inserted <- randomCoin
                           | Rejected => do putStrLn "bad coin"
                                            pure Rejected
                           putStrLn "good coin"
                           pure Inserted
runMachine Vend = putStrLn "Please take your chocolate"
runMachine {inState = (pounds, _)} GetCoins = putStrLn $ (show pounds) ++ " coins returned"
runMachine (Refill bars) = putStrLn $ "Chocolate remaining: " ++ (show bars)
runMachine (Display x) = putStrLn x
runMachine {inState = (pounds, bars)} GetInput
  = do putStrLn $ "Coins: " ++ (show pounds) ++ "; " ++
                  "Stock: " ++ (show bars)
       putStr "> "
       x <- getLine
       pure (strToInput x)
runMachine (Pure x) = pure x
runMachine (x >>= f) = do x' <- runMachine x
                          runMachine (f x')

data Fuel = Dry | More (Lazy Fuel)

partial
forever : Fuel
forever = More forever

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

mutual
  vend : MachineIO (pounds, chocs)
  vend {pounds = Z} = do Display "Insert a coin"
                         machineLoop
  vend {chocs = Z} = do Display "Out of stock"
                        machineLoop
  vend {pounds = (S k)} {chocs = (S j)} = do Vend
                                             Display "Enjoy!"
                                             machineLoop

  refill : (num : Nat) -> MachineIO (pounds, chocs)
  refill {pounds = Z} num = do Refill num
                               machineLoop
  refill {pounds = (S k)} num = do Display "Cannot refill: Coins in machine"
                                   machineLoop

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

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


data DoorState = DoorOpen | DoorClosed

data DoorCmd : Type ->
               DoorState -> DoorState ->
               Type where
  Open :     DoorCmd () DoorClosed DoorOpen
  Close :    DoorCmd () DoorOpen   DoorClosed
  RingBell : DoorCmd () DoorClosed DoorClosed

  Pure : ty -> DoorCmd ty state state
  (>>=) : DoorCmd a state1 state2 ->
          (a -> DoorCmd b state2 state3) ->
          DoorCmd b state1 state3

doorProg : DoorCmd () DoorClosed DoorClosed
doorProg = do RingBell
              Open
              Close


||| Monad morphisms and interaction with monad transformer stacks.
module Data.MSF.Trans

import Control.Monad.Identity
import Control.Monad.Reader
import Control.Monad.State
import Control.Monad.Writer
import Data.MSF.Core
import Data.MSF.Util
import Data.MSF.Running
import Data.SOP

--------------------------------------------------------------------------------
--          General Morphisms
--------------------------------------------------------------------------------

||| The most general structure-preserving monad morphism.
||| This can be used to change the input and output type plus
||| the effect type of an MSF without affecting its internal
||| structure (wiring of stream functions).
|||
||| For examples of usage, have a look at the implementations of
||| functions like `unreader`, `reader`, `unstate`, and similar.
export
morphGS :  Monad m1
        => (forall c . (i1 -> m1(o1,c)) -> i2 -> m2(o2,c))
        -> MSF m1 i1 o1
        -> MSF m2 i2 o2
morphGS f sf = feedback sf (arrM run >>^ \(o2,sf2) => [sf2,o2])
  where run : NP I [MSF m1 i1 o1,i2] -> m2 (o2, MSF m1 i1 o1)
        run [sf1,vi2] = f (step sf1) vi2

||| Applies a monad morphism to change the context of an MSF.
|||
||| ```idris example
||| fromPure : Monad m => MSF Identity i o -> MSF m i o
||| fromPure = morph (pure . runIdentity)
||| ```
export
morph : Monad m1 => (forall c . m1 c -> m2 c) -> MSF m1 i1 o1 -> MSF m2 i1 o1
morph f = morphGS (f .)

--------------------------------------------------------------------------------
--          Identity
--------------------------------------------------------------------------------

||| Puts a pure MSF (over the `Identity` monad) in another
||| monadic context.
export
fromPure : Monad m => MSF Identity i o -> MSF m i o
fromPure = morph (pure . runIdentity)

--------------------------------------------------------------------------------
--          State
--------------------------------------------------------------------------------

||| Alias for `constM get`
export
get : MonadState s m => MSF m i s
get = constM get

||| Alias for `constM put`
export
put : MonadState s m => MSF m s ()
put = arrM put

||| Alias for `constM modify`
export
modify : MonadState s m => MSF m (s -> s) ()
modify = arrM modify

||| Converts an outer `StateT` wrapper to an MSF converting
||| an additional argument of the state type.
export
fromState : Monad m => MSF (StateT s m) i o -> MSF m (NP I [s,i]) (NP I [s,o])
fromState =
  morphGS (\f,[vs,vi] => (\(vs2,vo,vc) => ([vs2,vo],vc)) <$> runStateT vs (f vi))

||| Runs the given stateful MSF as a feedback loop with `ini` as the
||| initial input.
|||
||| This is a shorthand for `feedback ini . fromState`.
export
loopState : Monad m => (ini : s) -> MSF (StateT s m) i o -> MSF m i o
loopState ini = feedback ini . fromState

||| Like `fromState` but drops the uninteresting unit in- and output.
export
fromState_ : Monad m => MSF (StateT s m) () () -> MSF m s s
fromState_ = morphGS (\f,vs => (\(vs2,_,vc) => (vs2,vc)) <$> runStateT vs (f ()))

||| Converts a state transforming MSF to one with its monadic context
||| wrapped in `StateT s`.
export
toState : Monad m => MSF m (NP I [s,i]) (NP I [s,o]) -> MSF (StateT s m) i o
toState =
  morphGS (\f,vi => ST $ \vs => (\([vs2,vo],vc) => (vs2,vo,vc)) <$> f [vs,vi])

||| Like `toState` but for MSFs without additional in- or output
export
toState_ : Monad m => MSF m s s -> MSF (StateT s m) () ()
toState_ = morphGS (\f,_ => ST $ \vs => (\(vs2,vc) => (vs2,(),vc)) <$> f vs)

--------------------------------------------------------------------------------
--          Reader
--------------------------------------------------------------------------------

||| Alias for `constM ask`
export
ask : MonadReader e m => MSF m i e
ask = constM ask

||| Converts an outer `ReaderT` wrapper to an MSF taking an
||| an additional input.
export
fromReader : Monad m => MSF (ReaderT e m) i o -> MSF m (NP I [e,i]) o
fromReader = morphGS (\f,[ve,vi] => runReaderT ve (f vi))

||| Converts the given MSF to use `env` as its environment.
|||
||| This is an alias for `fan [ const env, id ] >>> fromReader sf`.
export
withEnv : Monad m => (env : e) -> (sf : MSF (ReaderT e m) i o) -> MSF m i o
withEnv env sf = fan [ const env, id ] >>> fromReader sf

||| Like `unReader` but drops the uninteresting unit input.
export
fromReader_ : Monad m => MSF (ReaderT e m) () o -> MSF m e o
fromReader_ = morphGS (\f,ve => runReaderT ve (f ()))

||| Converts an MSF taking an additional input
||| to one with its monadic context wrapped in `ReaderT e`.
export
toReader : Monad m => MSF m (NP I [e,i]) o -> MSF (ReaderT e m) i o
toReader = morphGS (\f,vi => MkReaderT $ \ve => f [ve,vi])

||| Like `toReader` but for MSFs without additional input
export
toReader_ : Monad m => MSF m e o -> MSF (ReaderT e m) () o
toReader_ = morphGS (\f,_ => MkReaderT f)

--------------------------------------------------------------------------------
--          Writer
--------------------------------------------------------------------------------

||| Alias for `arrM tell`
export
tell : MonadWriter w m => MSF m w ()
tell = arrM tell

||| Converts an outer `WriterT` wrapper to an MSF producing
||| an additional output.
export
fromWriter : Monoid w => Monad m => MSF (WriterT w m) i o -> MSF m i (NP I [w,o])
fromWriter =
  morphGS (\f,vi => (\((vo,vc),vw) => ([vw,vo],vc)) <$> runWriterT (f vi))

||| Like `fromWriter` but ignores the uninteresting output.
export
fromWriter_ : Monoid w => Monad m => MSF (WriterT w m) i () -> MSF m i w
fromWriter_ =
  morphGS (\f,vi => (\((_,vc),vw) => (vw,vc)) <$> runWriterT (f vi))

||| Converts an MSF producing an additional output
||| to one with its monadic context wrapped in `WriterT w`.
export
toWriter : Monoid w => Monad m => MSF m i (NP I [w,o]) -> MSF (WriterT w m) i o
toWriter =
  morphGS (\f,vi =>
    MkWriterT $ \vw => (\([vw2,vo],vc) => ((vo,vc),vw <+> vw2)) <$> f vi)

||| Like `toWriter` but produces unit as output.
export
toWriter_ : Monoid w => Monad m => MSF m i w -> MSF (WriterT w m) i ()
toWriter_ =
  morphGS (\f,vi =>
    MkWriterT $ \vw => (\(vw2,vc) => (((),vc),vw <+> vw2)) <$> f vi)