module Sub07Apply108x27

import ProofColDivSeqBase
import ProofColDivSeqPostulate
import ProofColDivSeqPostuProof

%default total
-- %language ElabReflection

-- 3(36x+9) --F[5,-2]->C[4,-4]--> 3(32x+7)
export
apply108x27 : (Not . P) (S (S (S (S (plus (plus (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))
                                                (S (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))))
                                          (S (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))))))))
  -> (m : Nat **
        (LTE (S m)
             (S (S (S (S (plus (plus (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))
                                     (S (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))))
                               (S (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o)))))))))),
         (Not . P) m))
apply108x27 {o} col = ((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)))))))))))) ** (lte108x27 o, fc108x27To96x21 o col)) where
  lte108x27 : (o:Nat) -> LTE (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 (plus (plus (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))
                                  (S (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))))
                            (S (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))))))))
  lte108x27 Z = (lteSuccRight . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc . LTESucc) LTEZero
  lte108x27 (S o) = let lemma = lte108x27 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 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 o o) o)  (plus (plus o o) o))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus o o) o) (plus (plus o o) o))  (S (S (S (S (S (S (plus (plus (plus o o) o) (plus (plus o o) o)))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus o o) o) (plus (plus o o) o))  (S (S (S (S (S (plus (plus (plus o o) o) (plus (plus o o) o))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus o o) o) (plus (plus o o) o))  (S (S (S (S (plus (plus (plus o o) o) (plus (plus o o) o)))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus o o) o) (plus (plus o o) o))  (S (S (S (plus (plus (plus o o) o) (plus (plus o o) o))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus o o) o) (plus (plus o o) o))  (S (S (plus (plus (plus o o) o) (plus (plus o o) o)))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus o o) o) (plus (plus o o) o))  (S (plus (plus (plus o o) o) (plus (plus o o) o))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))  (S (S (S (S (S (S (S (S (S (S (S (S (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o)))))))))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))  (S (S (S (S (S (S (S (S (S (S (S (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))))))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))  (S (S (S (S (S (S (S (S (S (S (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o)))))))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))  (S (S (S (S (S (S (S (S (S (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))  (S (S (S (S (S (S (S (S (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o)))))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))  (S (S (S (S (S (S (S (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))  (S (S (S (S (S (S (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o)))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))  (S (S (S (S (S (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))  (S (S (S (S (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o)))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))  (S (S (S (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))  (S (S (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o)))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))  (S (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus (plus o o) o) (plus (plus o o) o))
                                                                                (S (plus (plus (plus o o) o) (plus (plus o o) o))))
                                                                                (S (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))))
                                    (S (S (S (S (S (S (S (S (S (S (S (S (plus (plus (plus (plus o o) o) (plus (plus o o) o))
                                                                                (S (plus (plus (plus o o) o)
                                                                                (plus (plus o o) o)))))))))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus (plus o o) o) (plus (plus o o) o))
                                                                                (S (plus (plus (plus o o) o) (plus (plus o o) o))))
                                                                                (S (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))))
                                    (S (S (S (S (S (S (S (S (S (S (S (plus (plus (plus (plus o o) o) (plus (plus o o) o))
                                                                                (S (plus (plus (plus o o) o)
                                                                                (plus (plus o o) o))))))))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus (plus o o) o) (plus (plus o o) o))
                                                                                (S (plus (plus (plus o o) o) (plus (plus o o) o))))
                                                                                (S (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))))
                                    (S (S (S (S (S (S (S (S (S (S (plus (plus (plus (plus o o) o) (plus (plus o o) o))
                                                                                (S (plus (plus (plus o o) o)
                                                                                (plus (plus o o) o)))))))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus (plus o o) o) (plus (plus o o) o))
                                                                                (S (plus (plus (plus o o) o) (plus (plus o o) o))))
                                                                                (S (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))))
                                    (S (S (S (S (S (S (S (S (S (plus (plus (plus (plus o o) o) (plus (plus o o) o))
                                                                                (S (plus (plus (plus o o) o)
                                                                                (plus (plus o o) o))))))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus (plus o o) o) (plus (plus o o) o))
                                                                                (S (plus (plus (plus o o) o) (plus (plus o o) o))))
                                                                                (S (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))))
                                    (S (S (S (S (S (S (S (S (plus (plus (plus (plus o o) o) (plus (plus o o) o))
                                                                                (S (plus (plus (plus o o) o)
                                                                                (plus (plus o o) o)))))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus (plus o o) o) (plus (plus o o) o))
                                                                                (S (plus (plus (plus o o) o) (plus (plus o o) o))))
                                                                                (S (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))))
                                    (S (S (S (S (S (S (S (plus (plus (plus (plus o o) o) (plus (plus o o) o))
                                                                                (S (plus (plus (plus o o) o)
                                                                                (plus (plus o o) o))))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus (plus o o) o) (plus (plus o o) o))
                                                                                (S (plus (plus (plus o o) o) (plus (plus o o) o))))
                                                                                (S (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))))
                                    (S (S (S (S (S (S (plus (plus (plus (plus o o) o) (plus (plus o o) o))
                                                                                (S (plus (plus (plus o o) o)
                                                                                (plus (plus o o) o)))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus (plus o o) o) (plus (plus o o) o))
                                                                                (S (plus (plus (plus o o) o) (plus (plus o o) o))))
                                                                                (S (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))))
                                    (S (S (S (S (S (plus (plus (plus (plus o o) o) (plus (plus o o) o))
                                                                                (S (plus (plus (plus o o) o)
                                                                                (plus (plus o o) o))))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus (plus o o) o) (plus (plus o o) o))
                                                                                (S (plus (plus (plus o o) o) (plus (plus o o) o))))
                                                                                (S (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))))
                                    (S (S (S (S (plus (plus (plus (plus o o) o) (plus (plus o o) o))
                                                                                (S (plus (plus (plus o o) o)
                                                                                (plus (plus o o) o)))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus (plus o o) o) (plus (plus o o) o))
                                                                                (S (plus (plus (plus o o) o) (plus (plus o o) o))))
                                                                                (S (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))))
                                    (S (S (S (plus (plus (plus (plus o o) o) (plus (plus o o) o))
                                                                                (S (plus (plus (plus o o) o)
                                                                                (plus (plus o o) o))))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus (plus o o) o) (plus (plus o o) o))
                                                                                (S (plus (plus (plus o o) o) (plus (plus o o) o))))
                                                                                (S (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))))
                                    (S (S (plus (plus (plus (plus o o) o) (plus (plus o o) o))
                                                                                (S (plus (plus (plus o o) o)
                                                                                (plus (plus o o) o)))))))) in
    rewrite (sym (plusSuccRightSucc (plus (plus (plus (plus (plus o o) o) (plus (plus o o) o))
                                                                                (S (plus (plus (plus o o) o) (plus (plus o o) o))))
                                                                                (S (plus (plus (plus (plus o o) o) (plus (plus o o) o)) (S (plus (plus (plus o o) o) (plus (plus o o) o))))))
                                    (S (plus (plus (plus (plus o o) o) (plus (plus o o) o))
                                                                                (S (plus (plus (plus o o) o)
                                                                                (plus (plus o 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
      (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


module Data.HashSet

import Data.Vector

%default total

public export
HashCode : Type
HashCode = Bits32

public export
interface (Eq a) => Hash a where
  hash : a -> HashCode

public export
Hash HashCode where
  hash = id

public export
Hash Int where
  hash = prim__zextInt_B32

public export
implementation (Hash a, Hash b) => Hash (a, b) where
  hash (x, y) = prim__xorB32 (997 * hash x) (991 * hash y)

Bitmap : Type
Bitmap = Bits32

Index : Type
Index = Nat

Cast Bits32 Nat where
  cast = cast . prim__zextB32_Int

mutual
  data Node a
    = Empty
    | Key HashCode a
    | HashCollision HashCode (Vector a)
    | SubTrie Bitmap (NodeList a)

  NodeList : Type -> Type
  NodeList a = Vector (Node a)

export
record HashSet a where
  constructor MkHashSet
  size : Nat
  root : NodeList a

Show a => Show (Node a) where
  show Empty = "E"
  show (Key h a) = "(K " ++ show a ++ ")"
  show (SubTrie bm l) = "(S " ++ show bm ++ " " ++ assert_total (show l) ++ ")"
  show _ = "*"

export
Show a => Show (HashSet a) where
  show (MkHashSet s r) = "HashSet " ++ show s ++ " " ++ show r

infixl 7 &
(&) : Bits32 -> Bits32 -> Bits32
(&) = prim__andB32

infixl 7 >>
(>>) : Bits32 -> Bits32 -> Bits32
(>>) = prim__lshrB32

infixl 7 <<
(<<) : Bits32 -> Bits32 -> Bits32
(<<) = prim__shlB32

(-) : Bits32 -> Bits32 -> Bits32
(-) x y = prim__zextInt_B32 (prim__zextB32_Int x - prim__zextB32_Int y)

shiftMask : Bits32 -> Bits32 -> Bits32 -> Bits32
shiftMask bits shift mask = (bits >> shift) & mask

popcnt : Bits32 -> Bits32
popcnt x =
  let x = x - shiftMask x 1 0x55555555
      x = (x & 0x33333333) + shiftMask x 2 0x33333333
      x = (x + (x >> 4)) & 0x0F0F0F0F
      x = x + (x >> 8)
      x = x + (x >> 16)
  in x & 0x0000003F

next5Bits : Bits32 -> HashCode -> HashCode
next5Bits level hashCode = shiftMask hashCode (5 * level) 0x1F

bitAt : Bits32 -> Bits32 -> Bool
bitAt pos bits = 1 == shiftMask bits pos 1

setBit : Bits32 -> Bits32 -> Bits32
setBit bitPos bits = prim__orB32 bits (1 << bitPos)

nodeIndex : Bits32 -> Bits32 -> Index
nodeIndex bitPos bitmap = cast (popcnt (bitmap & ((1 << bitPos) - 1)))

nodeAt : Index -> NodeList a -> Node a
nodeAt idx nodes = nodes !! idx

insertNode : Index -> NodeList a -> Node a -> NodeList a
insertNode idx nodes n = unsafeInsertAt idx n nodes

replaceNode : Index -> NodeList a -> Node a -> NodeList a
replaceNode idx nodes n = unsafeReplaceAt idx n nodes

{-
3.1 Search for a key Map Hash Array Mapped Trie (HAMT)

Compute a full 32 bit hash for the key, take the most significant t bits and use them as an integer to index into the root hash table. One of three cases may be encountered. First, the entry is empty indicating that the key is not in the hash tree. Second the entry is a Key/Value pair and the key either matches the desired key indicating success or not, indicating failure. Third, the entry has a 32 bit map sub-hash table and a sub-trie pointer, Base, that points to an ordered list of the non-empty sub-hash table entries.

Take the next 5 bits of the hash and use them as an integer to index into the bit Map. If this bit is a zero the hash table entry is empty indicating failure, otherwise, it’s a one, so count the one bits below it using CTPOP and use the result as the index into the non-empty entry list at Base. This process is repeated taking five more bits of the hash each time until a terminating key/value pair is found or the search fails. Typically, only a few iterations are required and it is important to note that the key is only compared once and that is with the terminating node key.
-}
export
member : (Hash a) => a -> HashSet a -> Bool
member key (MkHashSet _ root) =
  let rootPos = cast (next5Bits 0 hashCode)
  in memberOf root rootPos 1
  where
    hashCode : HashCode
    hashCode = hash key
    memberOf : NodeList a -> Index -> Bits32 -> Bool
    memberOf nodes index nextLevel =
      case nodeAt index nodes of
        Empty => False
        Key existingHashCode existingKey =>
          existingHashCode == hashCode && existingKey == key
        HashCollision existingHashCode keys =>
          existingHashCode == hashCode && elem key keys
        SubTrie bitmap nodes =>
          let
            bitPos = next5Bits nextLevel hashCode
            bitVal = bitAt bitPos bitmap
          in
            if bitVal
              then assert_total (memberOf nodes (nodeIndex bitPos bitmap) (nextLevel + 1))
              else False

{-
3.2 Insertion
The initial steps required to add a new key to the hash tree are identical to the search. The search algorithm is followed until one of two failure modes is encoun- tered.

Either an empty position is discovered in the hash table or a sub-hash table is found. In this case, if this is in the root hash table, the new key/value pair is simply substituted for the empty position. However, if in a sub-hash table then a new bit must be added to the bit map and the sub-hash table increased by one in size. A new sub-hash table must be allocated, the existing sub-table copied to it, the new key/value entry added in sub-hash sorted order and the old hash table made free.

Or the key will collide with an existing one. In which case the existing key must be replaced with a sub-hash table and the next 5 bit hash of the existing key computed. If there is still a collision then this process is repeated until no collision occurs. The existing key is then inserted in the new sub-hash table and the new key added. Each time 5 more bits of the hash are used the probability of a collision reduces by a factor of 1 . Occasionally an entire 32 bit hash may be consumed and 32 a new one must be computed to differentiate the two keys.
-}
insert' : (Hash a) => HashCode -> a -> HashSet a -> HashSet a
insert' hashCode key set@(MkHashSet size root) =
  case nodeAt rootPos root of
     Empty => insertRootNode (Key hashCode key)
     SubTrie bitmap nodes =>
       maybe set insertRootNode (insertIntoSubTrie bitmap nodes 1)
     node@(Key existingHashCode existingKey) =>
       if existingHashCode == hashCode
         then
           if existingKey == key
             then set
             else insertRootNode (collision existingKey)
         else
           maybe set insertRootNode (spawnSubTrie node existingHashCode 1)
     node@(HashCollision existingHashCode keys) =>
       if existingHashCode == hashCode
         then
           if elem key keys
             then set
             else insertRootNode (HashCollision hashCode (key :: keys))
         else
           maybe set insertRootNode (spawnSubTrie node existingHashCode 1)
  where
    rootPos : Index
    rootPos = cast (next5Bits 0 hashCode)
    insertRootNode : Node a -> HashSet a
    insertRootNode = MkHashSet (S size) . replaceNode rootPos root
    collision : a -> Node a
    collision existingKey = HashCollision hashCode (key :: singleton existingKey)
    mutual
      insertIntoSubTrie : Bitmap -> NodeList a -> Bits32 -> Maybe (Node a)
      insertIntoSubTrie bitmap nodes level =
        let
          bitPos = next5Bits level hashCode
          bitVal = bitAt bitPos bitmap
          nodePos = nodeIndex bitPos bitmap
        in
          if bitVal
            then SubTrie bitmap . replaceNode nodePos nodes <$> insertInto (nodeAt nodePos nodes) level
            else Just (SubTrie (setBit bitPos bitmap) (insertNode nodePos nodes (Key hashCode key)))

      insertInto : Node a -> Bits32 -> Maybe (Node a)
      insertInto (SubTrie bitmap nodes) level =
        assert_total (insertIntoSubTrie bitmap nodes (level + 1))
      insertInto node@(Key existingHashCode existingKey) level =
        if existingHashCode == hashCode
          then
            if existingKey == key
              then Nothing
              else Just (collision existingKey)
          else
            assert_total (spawnSubTrie node existingHashCode (level + 1))
      insertInto node@(HashCollision existingHashCode keys) level =
        if existingHashCode == hashCode
          then
            if elem key keys
              then Nothing
              else Just (HashCollision hashCode (key :: keys))
          else
            assert_total (spawnSubTrie node existingHashCode (level + 1))
      insertInto Empty _ = assert_unreachable

      spawnSubTrie : Node a -> HashCode -> Bits32 -> Maybe (Node a)
      spawnSubTrie node existingHashCode level =
        let bitPos = next5Bits level existingHashCode
            bitmap = setBit bitPos 0
        in insertIntoSubTrie bitmap (singleton node) level

export
insert : (Hash a) => a -> HashSet a -> HashSet a
insert key set = insert' (hash key) key set

export
empty : HashSet a
empty = MkHashSet 0 (replicate 32 Empty)

export
length : HashSet a -> Nat
length (MkHashSet size _) = size

fold : (acc -> elem -> acc) -> acc -> HashSet elem -> acc
fold f init (MkHashSet _ nodes) = foldNodes init nodes
  where
   mutual
    foldNodes : acc -> NodeList elem -> acc
    foldNodes acc nodes = foldl foldNode acc nodes
    foldNode : acc -> Node elem -> acc
    foldNode acc Empty = acc
    foldNode acc (Key _ k) = f acc k
    foldNode acc (HashCollision _ keys) = foldl f acc keys
    foldNode acc (SubTrie _ nodes) = assert_total (foldNodes acc nodes)

export
Foldable HashSet where
  foldl = fold
  foldr = fold . flip

export
filter : (Eq elem, Hash elem) => (elem -> Bool) -> HashSet elem -> HashSet elem
filter f (MkHashSet _ nodes) = foldNodes empty nodes
  where
   mutual
    foldNodes : HashSet elem -> NodeList elem -> HashSet elem
    foldNodes acc nodes = foldl foldNode acc nodes
    foldNode : HashSet elem -> Node elem -> HashSet elem
    foldNode acc Empty = acc
    foldNode acc (Key hashCode k) = insertWithHashCode hashCode acc k
    foldNode acc (HashCollision hashCode keys) = foldl (insertWithHashCode hashCode) acc keys
    foldNode acc (SubTrie _ nodes) = assert_total (foldNodes acc nodes)
    insertWithHashCode : HashCode -> HashSet elem -> elem -> HashSet elem
    insertWithHashCode hc acc e = if f e then insert' hc e acc else acc

export
into : (Hash a, Foldable f) => HashSet a -> f a -> HashSet a
into = foldl (flip insert)

export
fromList : (Hash a) => List a -> HashSet a
fromList = foldl (flip insert) empty

export
foldM : Monad m => (acc -> elem -> m acc) -> acc -> HashSet elem -> m acc
foldM f acc (MkHashSet _ nodes) = foldNodes f acc nodes
  where
   mutual
    foldNodes : (Monad m) => (a -> elem -> m a) -> a -> NodeList elem -> m a
    foldNodes f acc nodes = loop (length nodes) acc
      where
        loop Z     acc = pure acc
        loop (S k) acc = foldNode f acc (nodes !! k) >>= loop k
    foldNode : (Monad m) => (a -> elem -> m a) -> a -> Node elem -> m a
    foldNode f acc Empty = pure acc
    foldNode f acc (Key _ k) = f acc k
    foldNode f acc (HashCollision _ keys) = foldKeys f acc keys
    foldNode f acc (SubTrie _ nodes) = assert_total (foldNodes f acc nodes)
    foldKeys : (Monad m) => (a -> elem -> m a) -> a -> Vector elem -> m a
    foldKeys f acc keys = loop (length keys) acc
      where
        loop Z     acc = pure acc
        loop (S k) acc = f acc (keys !! k) >>= loop k


module Circuits.Idealised.Types

import Decidable.Equality

import Data.List.Elem

import public Circuits.Common

%default total

public export
data GateKind = AND  | IOR  | XOR
              | ANDN | IORN | XORN | JOIN

export
Show GateKind where
  show AND  = "and"
  show IOR  = "or"
  show XOR  = "xor"
  show ANDN = "nand"
  show IORN = "nor"
  show XORN = "xnor"
  show JOIN = "join"

public export
data Direction = INPUT | OUTPUT

Uninhabited (INPUT = OUTPUT) where
  uninhabited Refl impossible

DecEq Direction where
  decEq INPUT INPUT   = Yes Refl
  decEq INPUT OUTPUT  = No absurd
  decEq OUTPUT INPUT  = No (negEqSym absurd)
  decEq OUTPUT OUTPUT = Yes Refl

export
Show Direction where
  show INPUT  = "input"
  show OUTPUT = "output"

public export
data PortHasProperties : Direction -> DType -> (Direction, DType) -> Type
  where
    PortHas : PortHasProperties flow type (flow,type)

public export
data Ty : Type where
  TyUnit : Ty
  TyPort : (Direction, DType) -> Ty

  TyGate : Ty

export
Show Ty where
  show TyUnit = "()"
  show (TyPort (d,t)) = concat ["TyPort(", show d, ",", show t, ")"]
  show TyGate = "TyGate"

Uninhabited (TyUnit = (TyPort x)) where
  uninhabited Refl impossible

Uninhabited (TyUnit = TyGate) where
  uninhabited Refl impossible

Uninhabited (TyPort x = TyGate) where
  uninhabited Refl impossible

export
DecEq Ty where
  decEq TyUnit TyUnit = Yes Refl
  decEq TyUnit (TyPort x) = No absurd
  decEq TyUnit TyGate = No absurd

  decEq (TyPort x) TyUnit = No (negEqSym absurd)
  decEq (TyPort x) (TyPort y) with (decEq x y)
    decEq (TyPort x) (TyPort x) | (Yes Refl)
      = Yes Refl
    decEq (TyPort x) (TyPort y) | (No contra)
      = No (\Refl => contra Refl)
  decEq (TyPort x) TyGate = No (absurd)

  decEq TyGate TyUnit = No (negEqSym absurd)
  decEq TyGate (TyPort x) = No (negEqSym absurd)
  decEq TyGate TyGate = Yes Refl

public export
data Used : (Ty, Usage) -> Type where
  IsUsed : Used (type, USED)

Uninhabited (Used (type,FREE)) where
  uninhabited IsUsed impossible

export
used : (p : (Ty,Usage)) -> Dec (Used p)
used (ty,USED) = Yes IsUsed
used (ty,FREE) = No absurd

public export
data Use : (old : List (Ty, Usage))
        -> (prf : Elem (type,FREE) old)
        -> (new : List (Ty, Usage))
        -> Type
  where
    H : Use ((type,FREE) :: rest)
            Here
            ((type,USED) :: rest)
    T : Use old later new
     -> Use ((type',usage')::old) (There later) ((type',usage')::new)

export
use : (ctxt : List (Ty, Usage))
   -> (prf : Elem (type, FREE) ctxt)
          -> (DPair (List (Ty, Usage))
                    (Use ctxt prf))
use ((type, FREE) :: xs) Here
  = (MkDPair ((type, USED) :: xs) H)
use ((y, z) :: xs) (There x) with (use xs x)
  use ((y, z) :: xs) (There x) | ((MkDPair fst snd))
    = (MkDPair ((y, z) :: fst) (T snd))

export
useAlt : {ctxt : List (Ty, Usage)}
      -> (prf : Elem (type, FREE) ctxt)
             -> (DPair (List (Ty, Usage))
                       (Use ctxt prf))
useAlt {ctxt = ((type, FREE) :: xs)} Here
  = MkDPair ((type, USED) :: xs) H
useAlt {ctxt = (y :: xs)} (There x) with (useAlt x)
  useAlt {ctxt = ((y, z) :: xs)} (There x) | (MkDPair fst snd) = MkDPair ((y, z) :: fst) (T snd)

-- [ EOF ]


module Parser

import Data.String
import Data.List

public export
Input : Type
Input = List Char

public export
data ParseResult a = Done (a, Input) | Error String

-- To make a parser we need to take a function to maps from input to
-- A parse result and feed it into the AParser constuctor
public export
data Parser : Type -> Type where
  AParser : (Input -> ParseResult a) -> Parser a

%name Parser parser, parser2

-- To actually apply a parser we need to call the parse function
export
parse : Parser a -> Input -> ParseResult a
parse (AParser p) input = p input

export
doParse : Parser a -> String -> ParseResult a
doParse parser str = parse parser (unpack str)

export
eitherParse : Parser a -> String -> Either String a
eitherParse parser input =
  case doParse parser input of
    Done (a, rest) => Right a
    Error str => Left str

-- This is a more general form of map, it takes a parser, applies it
-- and the maps over both the result and the remaining input
export
continue : Parser a -> ((a, Input) -> ParseResult b) -> Parser b
continue parser f = AParser $ \input =>
    case parse parser input of
      Error str => Error str
      Done a => f a

public export
Functor ParseResult where
  map _ (Error str) = Error str
  map f (Done (a, input)) = Done (f a, input)

public export
Functor Parser where
  -- map : (a -> b) -> Parser a -> Parser b
  map f parser = AParser $ map f . parse parser

public export
Applicative Parser where
  (<*>) parser1 parser2 =
    AParser $ \input =>
      case parse parser1 input of
        Error err => Error err
        Done (a, rest) => parse (map a parser2) rest

  pure a = AParser \input => Done (a, input)

public export
Monad Parser where
  -- (>>=) : Parser a -> (a -> Parser b) -> Parser b
  (>>=) parser f = continue parser (\(a, rest) => parse (f a) rest)

-- Defining Basic parsers

export
end : ParseResult a
end = Error "End of Input"

export
failure : Parser a
failure = AParser $ \input => Error "Always fails"

export
parseError : String -> Parser a
parseError err = AParser $ \input => Error err

export
pToken : Parser Char
pToken = AParser $ \input =>
  case input of
    [] => end
    (c :: cs) => Done (c, cs)

export
validate : (a -> Bool) -> Parser a -> Parser a
validate f parser = do
  result <- parser
  if f result
    then pure result
    else parseError "Invalid Parse"

export
pBool : (Char -> Bool) -> Parser Char
pBool f = validate f pToken

-- parse a specific word
export
pTag : String -> Parser String
pTag tag = AParser $ go (unpack tag) []
  where
    go : List Char -> List Char -> Input -> ParseResult String
    go [] acc input = Done (pack . reverse $ acc, input)
    go (c :: cs) acc [] = end
    go (c :: cs) acc (n :: rest) =
      if c == n then go cs (n :: acc) rest
      else Error "Did not match tag"

-- Apply a parser N times
-- This should return a Vect
-- There must be a better way to do this
export
pN : Parser a -> Nat -> Parser (List a)
pN parser n = go parser n []
  where
    go : Parser a -> Nat -> List a -> Parser (List a)
    go parser 0 xs = failure
    go parser (S k) acc = do
      parsed <- parser
      let newAcc = parsed :: acc
      case k of
        0 => pure $ reverse newAcc
        k => go parser k newAcc

export
pChar : Char -> Parser Char
pChar c = pBool (==c)

export
pDigit : Parser Char
pDigit = pBool isDigit

export
many : Parser a -> Parser (List a)
many parser = AParser $ map reverse . go []
  where
    go : List a -> Input -> ParseResult (List a)
    go acc input =
      case parse parser input of
        Done (parsed, rest) => go (parsed :: acc) rest
        Error str => Done (acc, input)

export
manyString : Parser Char -> Parser String
manyString parser = map pack (many parser)

export
or : Parser a -> Parser a -> Parser a
or parser1 parser2 = AParser $ \input =>
  case parse parser1 input of
    Done (result, rest) => Done (result, rest)
    Error _ => parse parser2 input

infixr 4 <^>
export
(<^>) : Parser a -> Parser a -> Parser a
(<^>) x y = or x y

export
while : (Char -> Bool) -> Parser String
while f = manyString (pBool f)

export
until : (Char -> Bool) -> Parser String
until f = while (not . f)

export
pWhiteSpace : Parser String
pWhiteSpace = while isSpace

export
-- Parse until it encounters whitespace
-- Doesn't consume the whitespace
pWord : Parser String
pWord = until isSpace

export
mapM : (a -> Maybe b) -> Parser a -> Parser b
mapM f parser = do
  parsed <- parser
  case f parsed of
    Nothing => parseError "Invalid mapM"
    Just a => pure a

export
pInteger : Parser Integer
pInteger = mapM parseInteger (while validChar)
  where validChar : Char -> Bool
        validChar '+' = True
        validChar '-' = True
        validChar c = isDigit c

export
pNat : Parser Nat
pNat = map stringToNatOrZ (while isDigit)

export
andThen : Parser a -> Parser b -> Parser (a,b)
andThen parser1 parser2 = do
  parsed1 <- parser1
  parsed2 <- parser2
  pure (parsed1, parsed2)

infixl 3 <&>
export
(<&>) : Parser a -> Parser b -> Parser (a,b)
(<&>) x y = andThen x y

export
thenDrop : Parser a -> Parser b -> Parser a
thenDrop parser1 parser2 = map fst (andThen parser1 parser2)

infixl 3 :>
export
(:>) : Parser a -> Parser b -> Parser a
(:>) x y = thenDrop x y

export
sepBy : Parser a -> Parser b -> Parser (List a)
sepBy parser1 parser2 = do
  most <- many (thenDrop parser1 parser2)
  AParser $ (\input =>
      case parse parser1 input of
        Done (result, rest) => Done (most ++ [result], rest)
        Error str => Done (most, input))

export
-- Matches the end of the file
theEnd : Parser ()
theEnd = AParser $ \input =>
  if input == [] then Done ((), [])
  else Error "Expected End of File"

export
-- Parses a word and consume whitespace
pWord' : Parser String
pWord' = pWord :> pWhiteSpace

export
ignore : Parser a -> Parser ()
ignore parser = map (\i => ()) parser

export
oneOf : List (Parser a) -> Parser a
oneOf parsers = foldl (<^>) (parseError "No opertion found") parsers

export
ignoreThen : Parser a -> Parser b -> Parser b
ignoreThen parser1 parser2 = map snd (parser1 <&> parser2)

-- Parses a line as text and consumes the newline
-- TODO make this work on windows style newlines
export
line : Parser String
line = (until (=='\n')) `thenDrop` (pChar '\n')

export
pLines : Parser a -> Parser (List a)
pLines parser = sepBy parser line

infixl 3 <:
export
(<:) : Parser a -> Parser b -> Parser b
(<:) x y = ignoreThen x y


module LightClick.Connection

import Data.Vect

import Toolkit.Decidable.Informative
import Toolkit.Data.Rig

import LightClick.Types
import LightClick.Types.Equality
import LightClick.Types.Compatibility

%default total

namespace Port

  public export
  data Compatible : (left  : Ty (PORT l))
                 -> (right : Ty (PORT r))
                          -> Type
    where
      IsSafe : (flow  : Safe                   dl dr)
            -> (sens  : Sensitivity.Compatible sl sr)
            -> (wtype : WireType.Compatible    wl wr)
            -> (dtype : Data.Compatible        tl tr)
            -> Port.Compatible (TyPort l dl sl wl tl ul)
                               (TyPort r dr sr wr tr ur)

  directionUnsafe : (Safe dir x -> Void)
                 -> Compatible (TyPort l dir sense wty type usage) (TyPort r x y z t w)
                 -> Void
  directionUnsafe contra (IsSafe flow sens wtype dtype) = contra flow

  sensitivityInCompatible : (Compatible sense y -> Void)
                         -> Compatible (TyPort l dir sense wty type usage) (TyPort r x y z t w)
                         -> Void
  sensitivityInCompatible contra (IsSafe flow sens wtype dtype) = contra sens

  wireTypesInCompatible : (Compatible wty z -> Void)
                       -> Compatible (TyPort l dir sense wty type usage) (TyPort r x y z t w)
                       -> Void
  wireTypesInCompatible contra (IsSafe flow sens wtype dtype) = contra wtype

  dataTypeInCompatible : (Compatible type t -> Void)
                    -> Compatible (TyPort l dir sense wty type usage) (TyPort r x y z t w) -> Void
  dataTypeInCompatible contra (IsSafe flow sens wtype dtype) = contra dtype

  public export
  data Error = InCompatSensitivity Sensitivity.Error
             | InCompatDirection   Direction.Safe.Error
             | InCompatWTypes      Wire.Error
             | InCompatDTypes      Data.Error

  export
  compatible : (left  : Ty (PORT l))
            -> (right : Ty (PORT r))
                     -> DecInfo Port.Error
                               (Compatible left right)
  compatible (TyPort l dx sx wx tx ux) (TyPort r dy sy wy ty uy) with (safe dx dy)
    compatible (TyPort l dx sx wx tx ux) (TyPort r dy sy wy ty uy) | (Yes prfD) with (compatible sx sy)
      compatible (TyPort l dx sx wx tx ux) (TyPort r dy sy wy ty uy) | (Yes prfD) | (Yes prfS) with (compatible wx wy)
        compatible (TyPort l dx sx wx tx ux) (TyPort r dy sy wy ty uy) | (Yes prfD) | (Yes prfS) | (Yes prfW) with (compatible tx ty)
          compatible (TyPort l dx sx wx tx ux) (TyPort r dy sy wy ty uy) | (Yes prfD) | (Yes prfS) | (Yes prfW) | (Yes prfT)
            = Yes (IsSafe prfD prfS prfW prfT)

          compatible (TyPort l dx sx wx tx ux) (TyPort r dy sy wy ty uy) | (Yes prfD) | (Yes prfS) | (Yes prfW) | (No msg contra)
            = No (InCompatDTypes msg) (dataTypeInCompatible contra)
        compatible (TyPort l dx sx wx tx ux) (TyPort r dy sy wy ty uy) | (Yes prfD) | (Yes prfS) | (No msg contra)
          = No (InCompatWTypes msg) (wireTypesInCompatible contra)
      compatible (TyPort l dx sx wx tx ux) (TyPort r dy sy wy ty uy) | (Yes prfD) | (No msg contra)
        = No (InCompatSensitivity msg) (sensitivityInCompatible contra)
    compatible (TyPort l dx sx wx tx ux) (TyPort r dy sy wy ty uy) | (No msg contra)
      = No (InCompatDirection msg) (directionUnsafe contra)

namespace Fanout

  namespace PortList

    public export
    data Compatible : (input : Ty (PORT s))
                   -> (fan   : DVect String (Ty . PORT) n names)
                            -> Type
      where
        Empty : PortList.Compatible i Nil
        Cons : {x : Ty (PORT s)}
            -> {rest : DVect String (Ty . PORT) n names}
            -> Port.Compatible i x
            -> PortList.Compatible i rest
            -> PortList.Compatible i (x::rest)

    headNotCompat : {xs : DVect String (Ty . PORT) n names}
                 -> (Port.Compatible i x -> Void)
                 -> PortList.Compatible i (x `DVect.(::)` xs)
                 -> Void
    headNotCompat contra (Cons prf rest) = contra prf

    restNotCompat : {xs : DVect String (Ty . PORT) n names}
                 -> (Compatible i xs -> Void)
                 -> Compatible i (x `DVect.(::)` xs)
                 -> Void
    restNotCompat contra (Cons prf rest) = contra rest

    public export
    data Error = PListError Nat (Ty (PORT s)) Port.Error

    export
    compatible : (input : Ty (PORT s))
              -> (ports : DVect String (Ty . PORT) n names)
                      -> DecInfo PortList.Error
                                 (PortList.Compatible input ports)
    compatible i Nil = Yes Empty
    compatible i (x :: xs) with (compatible i x)
      compatible i (x :: xs) | (Yes prfX) with (compatible i xs)
        compatible i (x :: xs) | (Yes prfX) | Yes prfXs = Yes (Cons prfX prfXs)

        compatible i (x :: xs) | (Yes prfX) | (No (PListError pos y err) contra)
          = No (PListError (S pos) y err) (restNotCompat contra)
      compatible i (x :: xs) | (No msg contra) = No (PListError Z x msg) (headNotCompat contra)

  public export
  data Compatible : (input : Ty (PORT s))
                 -> (fan   : DVect String (Ty . PORT) (S (S n)) names)
                 -> Type
    where
      CompatFanout : PortList.Compatible input fan
                  -> Compatible input fan

  notCompatFanout : (PortList.Compatible input (x :: (y :: fan)) -> Void)
                 -> Fanout.Compatible input (x :: (y :: fan)) -> Void
  notCompatFanout contra (CompatFanout prf) = contra prf

  export
  compatible : (input : Ty (PORT s))
            -> (fan   : DVect String (Ty . PORT) (S (S n)) names)
                     -> DecInfo PortList.Error
                                (Fanout.Compatible input fan)

  compatible input (x::y::fan) with (PortList.compatible input (x::y::fan))
    compatible input (x::y::fan) | Yes prf = Yes (CompatFanout prf)
    compatible input (x::y::fan) | No msg contra = No msg (notCompatFanout contra)

namespace Mux

  public export
  data Error = CtrlNotSafe (Ty (PORT s)) Port.Error
             | MuxNotSafe (PortList.Error)

  namespace PortList

    public export
    data Compatible : (ports : DVect String (Ty . PORT) n names)
                   -> (o     : Ty (PORT s))
                            -> Type
      where
        Empty : Compatible Nil o
        Cons : {x : Ty (PORT s)}
            -> {rest : DVect String (Ty . PORT) n names}
            -> Port.Compatible x o
            -> PortList.Compatible     rest o
            -> PortList.Compatible (x::rest) o

    headNotCompat : {xs : DVect String (Ty . PORT) n names}
                 -> (Port.Compatible x o -> Void)
                 -> PortList.Compatible (x `DVect.(::)` xs) o
                 -> Void
    headNotCompat contra (Cons prf rest) = contra prf

    restNotCompat : {xs : DVect String (Ty . PORT) n names}
                 -> (Compatible xs o -> Void)
                 -> Compatible (x `DVect.(::)` xs) o
                 -> Void
    restNotCompat contra (Cons prf rest) = contra rest

    export
    compatible : (ports : DVect String (Ty . PORT) n names)
              -> (o     : Ty (PORT s))
                        -> DecInfo PortList.Error
                                   (PortList.Compatible ports o)
    compatible Nil o = Yes Empty
    compatible (x :: xs) o with (compatible x o)
      compatible (x :: xs) o | (Yes prfX) with (compatible xs o)
        compatible (x :: xs) o | (Yes prfX) | Yes prfXs = Yes (Cons prfX prfXs)

        compatible (x :: xs) o | (Yes prfX) | (No (PListError pos y err) contra)
          = No (PListError (S pos) y err) (restNotCompat contra)
      compatible (x :: xs) o | (No msg contra) = No (PListError Z x  msg) (headNotCompat contra)

  namespace Fanin

    public export
    data Compatible : (fan   : DVect String (Ty . PORT) (S (S n)) names)
                   -> (output : Ty (PORT s))
                   -> Type
      where
        CompatFanin : PortList.Compatible fan output
                   -> Compatible fan output

    notCompatFanin : (PortList.Compatible (x :: (y :: fan)) output -> Void)
                   -> Fanin.Compatible (x :: (y :: fan)) output -> Void
    notCompatFanin contra (CompatFanin prf) = contra prf

    export
    compatible : (fan    : DVect String (Ty . PORT) (S (S n)) names)
              -> (output : Ty (PORT s))
                       -> DecInfo PortList.Error
                                  (Fanin.Compatible fan output)

    compatible (x::y::fan) output with (PortList.compatible (x::y::fan) output)
      compatible (x::y::fan) output | Yes prf = Yes (CompatFanin prf)
      compatible (x::y::fan) output | No msg contra = No msg (notCompatFanin contra)

  public export
  data Compatible : (fan    : DVect String (Ty . PORT) (S (S n)) names)
                 -> (ctrl   : Ty (PORT c))
                 -> (output : Ty (PORT o))
                           -> Type
    where
      CompatMux : (fan  : DVect String (Ty . PORT) (S (S n)) names)
               -> (ctrl : Ty (PORT c))
               -> (out  : Ty (PORT o))
               -> (safeCTRL  : Port.Compatible ctrl (Control.mkDual ctrl))
               -> (safeFanIn : Fanin.Compatible fan out)
                            -> Compatible fan ctrl out

  faninNotCompat : (Fanin.Compatible fan output -> Void)
                -> Compatible fan ctrl output -> Void
  faninNotCompat contra (CompatMux f c o prfCtrl prfFanin) = contra prfFanin

  ctrlNotCompat : {fan : DVect String (Ty . PORT) (S (S n)) names}
               -> (Port.Compatible ctrl (Control.mkDual ctrl) -> Void)
               -> Compatible fan ctrl output
               -> Void
  ctrlNotCompat contra (CompatMux f c o prfCtrl prfFanin) = contra prfCtrl

  export
  compatible : (fanin  : DVect String (Ty . PORT) (S (S n)) names)
            -> (ctrl   : Ty (PORT c))
            -> (output : Ty (PORT o))
            -> DecInfo Mux.Error
                       (Compatible fanin ctrl output)
  compatible fan ctrl output with (Fanin.compatible fan output)
    compatible fan ctrl output | (Yes prfFan) with (compatible ctrl (Control.mkDual ctrl))
      compatible fan ctrl output | (Yes prfFan) | Yes prfCtrl = Yes (CompatMux fan ctrl output prfCtrl prfFan)

      compatible fan ctrl output | (Yes prfFan) | No msg contra
        = No (CtrlNotSafe (Control.mkDual ctrl) msg) (ctrlNotCompat contra)
    compatible fan ctrl output | No msg contra
      = No (MuxNotSafe msg) (faninNotCompat contra)

-- [ EOF ]


module ITree
import Control.Monad.State

-- Based on https://arxiv.org/pdf/1906.00046.pdf

data ITree : (e : Type -> Type) -> (r : Type) -> Type where
  Ret : r -> ITree e r
  Tau : Inf (ITree e r) -> ITree e r
  Vis : e a -> (a -> Inf (ITree e r)) -> ITree e r

implementation Functor (ITree e) where
  map f (Ret x) = Ret $ f x
  map f (Tau tr) = Tau $ map f tr
  map f (Vis e k) = Vis e (\x => map f (k x))

implementation Applicative (ITree e) where
  pure a = Ret a

  (Ret f) <*> tra = map f tra
  (Tau trf) <*> tra = Tau $ trf <*> tra
  (Vis e k) <*> tra = Vis e (\x => k x <*> tra)

implementation Monad (ITree e) where
  (Ret r) >>= f = f r
  (Tau tr) >>= f = Tau $ tr >>= f
  (Vis e f') >>= f = Vis e (\x => f' x >>= f)

interface Monad m => MonadIter (m : Type -> Type) where
  iter : (a -> m (Either a b)) -> a -> m b

implementation MonadIter (ITree e) where
  iter body a = do {
                  ab <- body a;
                  case ab of
                    Left a => Tau $ iter body a
                    Right b => Ret b
                }

implementation MonadIter m => MonadIter (StateT s m) where
  iter body a = ST $ \s => iter (\(a, s) =>
    do {
      (ab, s) <- runStateT (body a) s
      pure $ case ab of
              Left a => Left (a, s)
              Right b => Right (b, s)
    }) (a, s)

interp : MonadIter m => ({r : Type} -> e r -> m r) -> {r : Type} -> ITree e r -> m r
interp h = iter (\tr => case tr of
                          Ret r => pure $ Right r
                          Tau tr => pure $ Left tr
                          Vis e k => h e >>= (\x => pure $ Left (k x)))

data IO' : Type -> Type where
  Input : IO' Nat
  Output : Nat -> IO' ()

spin : ITree IO' ()
spin = Tau spin

kill9 : ITree IO' ()
kill9 = Vis Input (\x => if x == 9 then Ret () else kill9)

data StateE : (s : Type) -> Type -> Type where
  Get : StateE s s
  Put : s -> StateE s ()

handlerState : StateE s r -> StateT s (ITree e) r
handlerState Get = ST $ \s => Ret (s, s)
handlerState (Put s') = ST $ \s => Ret ((), s')

interpState : MonadIter m => ({r : Type} -> e r -> StateT s m r) -> ITree e r -> StateT s m r
interpState h = interp h


module FLK_sos

import FLK_ast
import Data.SortedMap

-- operational semanitcs for FLK
-- TODO: Need way to have abstractions step
mutual
  infixr 5 >==> -- read like => in SOS-land
  (>==>) : (CF a) -> (CF b) -> Type
  l >==> r = Step l r

  syntax "[" [ex1] "=>" [ex2] "]"=
    ex1 >- _ `Step` ex2 >- _

  syntax "[" [ex1] "," [env1] "=>" [ex2] "," [env2] "]"=
    ex1 >- env1 `Step` ex2 >- env2

  data Step  : (CF a) -> (CF b) -> Type where
    PNot     :  [Prim1 Not (B b), e => B (not b),  e]

    PrimStep :  [b => b']
             -> [Prim1 o b, e => Prim1 o b', e]

    ArithOp  :  {o : Op2 Arith}
             -> [Prim2 o (N n1) (N n2), e => N (arithOp o n1 n2), e]

    RelOp    :  {o : Op2 Rel}
             -> [Prim2 o (N b1) (N b2), e => B (relop o b1 b2), e]

    GenOp    :  {o : Op2 Gen} -> {op1 : Exp Done} -> {op2 : Exp Done}
             -> [Prim2 o op1 op2, e => genOp o op1 op2, e]

    Prim2L   :  [b => b']
             -> [Prim2 o b re, e => Prim2 o b' re, e]

    Prim2R   :  {le : Exp Done}
             -> [b => b']
             -> [Prim2 o le b, e => Prim2 o le b', e]

    IfCase   :  [b => b']
             -> [If b t f, e' => If b' t f, e']

    IfT      :  [If (B True) t f, e => t, e]

    IfF      :  [If (B False) t f, e => f, e]

    ClosLam  :  [Abs ident exp, e => Clos e (Abs ident exp), e]

    AppFunT  :  [b => b']
             -> [App b exp, e => App b' exp, e]

    AppArgT  :  [arg => arg']
             -> [App (Clos env lam) arg, e => App (Clos env lam) arg', e]

    AppLam   :  {val : Exp Done}
             -> [App (Clos env (Abs ident body)) val, e => body, insert ident (Left val) env]

    IdTrans  :  {e : Env} -> {n : Ident}
             -> Sigma (Exp Done) (\v => lookup n e = (Just (Left v)))
             -> [(Id n), e => v, e]

    IdRecTrans :  {e : Env} -> {n : Ident}
              -> Sigma (Exp RecLam) (\v => lookup n e = (Just (Right v)))
              -> [(Id n), e => v, e]

    RecTrans :  [(Rec ident exp), e => exp, insert ident (Right $ Rec ident exp) e]

  syntax "[[" [str] "," [sub] "]]" = str++" ["++(show sub)++"]";

  instance Show (Step a b) where
    show PNot = "PNot"
    show (PrimStep w) = [["PrimStep", w]]
    show ArithOp = "ArithOp"
    show RelOp = "RelOp"
    show GenOp = "GenOp"
    show (Prim2L t) = [["Prim2L", t]]
    show (Prim2R s) = [["Prim2R", s]]
    show (IfCase s) = [["IfCase", s]]
    show IfT = "IfT"
    show IfF = "IfF"
    show ClosLam = "ClosLam"
    show (AppFunT s) = [["AppFunT", s]]
    show (AppArgT z) = [["AppArgT", z]]
    show AppLam = "AppLam"
    show (IdTrans x) = "IdTrans"
    show (IdRecTrans x) = "IdRecTrans"
    show RecTrans = "RecTrans"

-- Simple rule application
testStep1 : Prim1 Not (B True) >- e >==> (B False) >- e
testStep1 = PNot

-- Compose two rules
testStep : [(Prim1 Not (Prim1 Not (B False))), e => Prim1 Not (B True), e]
testStep {e=e} = PrimStep $ PNot {e=e}

takeStep : {state' : CF b} -> {rule : state >==> state'} -> (state : CF a) ->  CF b
takeStep {state' = s} _ = s

default : Exp a -> CF a
default x = x >- emptyEnv

opResolve : {e : Env}
         -> (op : Op2 a)
         -> (o1 : Exp Done)
         -> (o2 : Exp Done)
         -> Maybe (Sigma (Exp Done) (\state => Step ((Prim2 op o1 o2) >- e) (state >- e)))
opResolve EQ op1 op2 = Just ((genOp EQ op1 op2) ** GenOp)
opResolve NEQ op1 op2 = Just ((genOp NEQ op1 op2) ** GenOp)
opResolve Plus (N k) (N z) =  Just ((N $ arithOp Plus k z) ** ArithOp)
opResolve Minus (N k) (N z) = Just ((N $ arithOp Minus k z) ** ArithOp)
opResolve LThan (N k) (N z) =  Just ((B $ relop LThan k z) ** RelOp)
opResolve LEThan (N k) (N z) = Just ((B $ relop LEThan k z) ** RelOp)
opResolve GThan (N k) (N z) =  Just ((B $ relop GThan k z) ** RelOp)
opResolve GEThan (N k) (N z) =  Just ((B $ relop GEThan k z) ** RelOp)
opResolve x x1 x2 = Nothing

mutual
  -- Evaluator based on operational semantics
  -- TODO: add printing, with effects and such
  goTill : Sigma Status (\s => CF s) -> Sigma Status (\s' => CF s')
  goTill (MkSigma Inter pf) with (search pf)
    goTill (MkSigma Inter pf) | Nothing = MkSigma Inter pf
    goTill (MkSigma Inter pf) | (Just (MkSigma x (MkSigma y z))) = goTill $ MkSigma x y
  goTill p@(MkSigma Done pf) = p
  goTill (MkSigma Lam pf) with (searchLam pf)
    goTill (MkSigma Lam pf) | Nothing = (MkSigma Lam pf)
    goTill (MkSigma Lam pf) | (Just (MkSigma x (MkSigma y z))) = goTill $ MkSigma x y
  goTill (MkSigma RecLam pf) = let (x ** (y ** z)) = recTrans pf in goTill (x ** y)

  -- Search rules for the semantics
  -- Forall states, we get
  --      Maybe (exists a Status such that there exists a state with
  --            that status that is transitioned to by the state)
  search : (start : CF Inter) -> Maybe (Sigma Status (\s => (Sigma (CF s) (\o => Step start o))))
  search ((App z w) >- y)     = search_app y z w
  search ((If z w s) >- y)    = search_if z w s y
  search ((Prim1 z w) >- y)   = search_prim1 z w y
  search ((Prim2 z w s) >- y) = search_prim2 z w s y
  search ((Id x) >- y) with (idSteps x y)
    search ((Id x) >- y) | Nothing with (idRecSteps x y)
      search ((Id x) >- y) | Nothing | Nothing = Nothing
      search ((Id x) >- y) | Nothing | (Just (v ** pf)) =
        Just $ (RecLam ** (v >- y ** IdRecTrans (v ** pf)))
    search ((Id x) >- y) | Just (v ** pf) = Just $ (Done ** (v >- y ** IdTrans (v ** pf)))

  -- This is a macro that will do most of the intermediate computations needed for some common
  -- lemmas
  -- My understanding is that this sort of thing should be done with a high-level tactic
  -- involving reflection. I do not fully understand how to use this feature, so I am using the
  -- 'syntax' feature as a macro system of sorts
  syntax "[[" {state} "," {trans} "," [env] "," [ex] "," [newstate] "," [rule] "]]" =
               case (search $ ex >- env) of {
                 Nothing => Nothing ;
                 Just (status ** (state >- y' ** trans)) =>
                      Just (Inter ** (newstate >- env ** rule));
               }

  -- transition intermediate-result composite expressions. wrapper for above macro
  syntax "[[" [env] ";" [ex] ";" [newstate] ";" [rule] "]]" =
    [[ state, trans, env, ex, (newstate state), (rule trans)]]

  -- transition abstractions
  syntax "<[" [trans] "," [abs] "," [env] "," [state] "]>" =
    Just $ (_ ** (((state (Clos env abs)) >- env) ** trans ClosLam));
  -- transition rec expressions
  syntax "<[" [trans] ";" [rec] ";" [env] ";" [state] "]>" =
    let (tag ** (newstate >- env' ** newtrans)) = recTrans (rec >- env) in
        Just $ (_ ** ((state newstate) >- env ** trans newtrans));

  search_prim2_rhs_7 : (z : Op2 y)
                    -> (exp : Exp Done)
                    -> (s : Exp b)
                    -> (y : SortedMap String (Either (Exp Done) (Exp RecLam)))
                    -> Maybe (Sigma Status (\s2 => Sigma (CF s2)
                                   (\o => Step ((Prim2 z exp s) >- y) o)))
  search_prim2_rhs_7 z exp (App x w) y = [[y; (App x w); Prim2 z exp; Prim2R]]
  search_prim2_rhs_7 z exp (Abs x w) y = <[Prim2R, (Abs x w), y, Prim2 z exp]>
  search_prim2_rhs_7 z exp (Rec x w) y = <[Prim2R; (Rec x w); y; Prim2 z exp]>
  search_prim2_rhs_7 z exp (If x w s) y = [[y; If x w s; Prim2 z exp; Prim2R]]
  search_prim2_rhs_7 z exp (Prim1 x w) y = [[y; Prim1 x w; Prim2 z exp; Prim2R]]
  search_prim2_rhs_7 z exp (Prim2 w s t) y = [[y; Prim2 w s t; Prim2 z exp; Prim2R]]
  search_prim2_rhs_7 z exp (Id x) y = [[y; Id x; Prim2 z exp; Prim2R]]
  search_prim2_rhs_7 z exp (N k) y with (opResolve {e=y} z exp (N k))
    search_prim2_rhs_7 z exp (N k) y | Nothing = Nothing
    search_prim2_rhs_7 z exp (N k) y | (Just (exp ** step)) = Just (Done ** (exp >- y ** step))
  search_prim2_rhs_7 z exp (B x) y with (opResolve {e=y} z exp (B x))
    search_prim2_rhs_7 z exp (B x) y | Nothing = Nothing
    search_prim2_rhs_7 z exp (B x) y | (Just (exp ** step)) = Just (Done ** (exp >- y ** step))
  search_prim2_rhs_7 z exp (Clos x w) y with (opResolve {e=y} z exp (Clos x w))
    search_prim2_rhs_7 z exp (Clos x w) y | Nothing = Nothing
    search_prim2_rhs_7 z exp (Clos x w) y | (Just (exp ** step)) = Just (Done ** (exp >- y ** step))

  search_prim2 : (z : Op2 y)
              -> (w : Exp a)
              -> (s : Exp b)
              -> (y : SortedMap String (Either (Exp Done) (Exp RecLam)))
              -> Maybe (Sigma Status (\s1 => Sigma (CF s1)
                                             (\o => Step ((Prim2 z w s) >- y) o)))
  search_prim2 z (App x w) s y = [[y; (App x w); \st => Prim2 z st s; Prim2L]]
  search_prim2 z (Abs x w) s y = <[Prim2L, (Abs x w), y, \st => Prim2 z st s]>
  search_prim2 z (Rec x w) s y = <[Prim2L; (Rec x w); y; \st => Prim2 z st s]>
  search_prim2 z (If x w t) s y = [[y; If x w t; \st => Prim2 z st s; Prim2L]]
  search_prim2 z (Prim1 x w) s y = [[y; Prim1 x w; \st => Prim2 z st s; Prim2L]]
  search_prim2 z (Prim2 w t u) s y = [[y; Prim2 w t u; \st => Prim2 z st s; Prim2L]]
  search_prim2 z (Id x) s y = [[y; Id x; \st => Prim2 z st s; Prim2L]]
  search_prim2 z (N k) s y = search_prim2_rhs_7 z (N k) s y
  search_prim2 z (B x) s y = search_prim2_rhs_7 z (B x) s y
  search_prim2 z (Clos x w) s y = search_prim2_rhs_7 z (Clos x w) s y

  total
  searchLam : (start : CF Lam)
           -> Maybe (Sigma Status (\s => (Sigma (CF s) (\o => Step start o))))
  searchLam ((Abs x z) >- y) = <[ id , (Abs x z), y, id ]>

  total
  recTrans : (start : CF RecLam)
          -> (Sigma Status (\s => (Sigma (CF s) (\o => Step start o))))
  recTrans ((Rec x z) >- y) = (getTag z ** (z >- (insert x (Right $ Rec x z) y) ** RecTrans))

  total
  searchRec : (start : CF RecLam)
           -> Maybe (Sigma Status (\s => (Sigma (CF s) (\o => Step start o))))
  searchRec r = Just $ recTrans r

  search_if : (z : Exp a)
           -> (w : Exp b)
           -> (s : Exp c)
           -> (y : Env)
           -> Maybe (Sigma Status (\s1 => Sigma (CF s1) (\o => Step ((If z w s) >- y) o)))
  search_if (Abs x z) w s y  = <[IfCase, (Abs x z), y, \c => If c w s]> --Nothing
  search_if (Rec i b) w s y  = <[IfCase; (Rec i b); y; \c => If c w s]>
  search_if (N _) _ _ _      = Nothing
  search_if (Clos _ _) _ _ _ = Nothing
  search_if (B x) w s y = case x of
                               True  => let t = getTag w in
                                            Just (t ** (w >- y ** IfT))
                               False => let t = getTag s in
                                            Just (t ** (s >- y ** IfF))
  search_if (App lam st)  w s y = [[state, trans, y, App lam st, If state w s , IfCase trans]]
  search_if (If x z t)    w s y = [[y; (If x z t); \state => If state w s; IfCase]]
  search_if (Prim1 x z)   w s y = [[y; (Prim1 x z); \state => If state w s; IfCase]]
  search_if (Prim2 x z t) w s y = [[y; (Prim2 x z t); \state => If state w s; IfCase]]
  search_if (Id x)        w s y = [[y; (Id x); \state => If state w s; IfCase]]

  search_prim1 : (z : Op1)
              -> (w : Exp a)
              -> (y : Env)
              -> Maybe (Sigma Status (\s => Sigma (CF s) (\o => Step ((Prim1 z w) >- y) o)))
  search_prim1 Not (Abs x z)  y = <[PrimStep, (Abs x z), y, (Prim1 Not)]>
  search_prim1 Not (Rec x z)  y = <[PrimStep; (Rec x z); y; (Prim1 Not)]>
  search_prim1 Not (N k)      y = Nothing
  search_prim1 Not (Clos x z) y = Nothing
  search_prim1 Not (B x) y = Just $ (Done ** (B (not x) >- y ** PNot))
  search_prim1 Not (App x z)     y = [[y; (App x z); Prim1 Not; PrimStep]]
  search_prim1 Not (If x z w)    y = [[y; (If x z w); Prim1 Not; PrimStep]]
  search_prim1 Not (Prim1 x z)   y = [[y; (Prim1 x z); Prim1 Not; PrimStep]]
  search_prim1 Not (Prim2 z w s) y = [[y; (Prim2 z w s); Prim1 Not; PrimStep]]
  search_prim1 Not (Id x)        y = [[y; (Id x); Prim1 Not; PrimStep]]

  search_subst_env : (y : Env) -- Outer environment
                  -> (x : Env) -- Closure environment
                  -> (z : Exp Lam)
                  -> (k : Exp Done)
                  -> Maybe (Sigma Status
                                 (\s => Sigma (CF s)
                                              (\o => Step ((App (Clos x z) k) >- y) o)))
  search_subst_env y x (Abs iden w) k =
    Just $ (getTag w ** (w >- (insert iden (Left k) x) ** AppLam))

  search_app : (y : Env)
            -> (z : Exp a)
            -> (w : Exp b)
            -> Maybe (Sigma Status (\s => Sigma (CF s) (\o => Step ((App z w) >- y) o)))
  search_app y p@(Abs id body) w  = <[AppFunT, (Abs id body), y, (\clos => App clos w)]>
  search_app y (App e b)        w = [[y; (App e b); \s => App s w; AppFunT]]
  search_app y (If c t f)       w = [[y; (If c t f); \s => App s w; AppFunT]]
  search_app y (Prim1 op oa)    w = [[y; (Prim1 op oa); \s => App s w; AppFunT]]
  search_app y (Prim2 op o1 o2) w = [[y; (Prim2 op o1 o2); \s => App s w; AppFunT]]
  search_app y (Id x)           w = [[y; (Id x); \s => App s w; AppFunT]]
  search_app y (N k)            w = Nothing
  search_app y (B x)            w = Nothing
  search_app y (Rec x z)        w   = <[AppFunT; (Rec x z); y; (\clos => App clos w)]>
  search_app y (Clos x z) (Rec w s) = <[AppArgT; (Rec w s); y; (\arg => App (Clos x z) arg)]>
  search_app y (Clos x z) (App e b)        = [[y; App e b; App (Clos x z); AppArgT]]
  search_app y (Clos x z) (If c t f)       = [[y; If c t f; App (Clos x z); AppArgT]]
  search_app y (Clos x z) (Prim1 op oa)    = [[y; Prim1 op oa; App (Clos x z); AppArgT]]
  search_app y (Clos x z) (Prim2 op o1 o2) = [[y; Prim2 op o1 o2; App (Clos x z); AppArgT]]
  search_app y (Clos x z) (Id i)           = [[y; Id i; App (Clos x z); AppArgT]]
  search_app y (Clos x z) p@(Abs _ _)      = Just $ (Inter **
                                                     (App (Clos x z) (Clos y p) >- y **
                                                       AppArgT ClosLam))
  search_app y (Clos x z) p@(N k)          = search_subst_env y x z p
  search_app y (Clos x z) p@(B w)          = search_subst_env y x z p
  search_app y (Clos x z) p@(Clos w s)     = search_subst_env y x z p


module Main

import Effect.StdIO
import VectMissing

-----------------------------------------------------------------------
-- GAME STATE
-----------------------------------------------------------------------

{- First, the game state, HState, where the type specifies how many guesses
are left and how many missing letters there are still to get. -}

data HState : Nat -> Nat -> Type where
     MkH : (word : String) ->
           (guesses : Nat) ->
           (got : List Char) ->
           (missing : Vect m Char) ->
           HState guesses m

instance Default (HState 0 0) where
    default = MkH "" 0 [] []

instance Show (HState guesses m) where
    show (MkH w _ got missing)
         = let w' = pack (map showGot (unpack w)) in
               w' ++ "\n\n" ++ show guesses ++ " guesses left"
      where showGot : Char -> Char
            showGot ' ' = '/'
            showGot c = if ((not (isAlpha c)) || (c `elem` got)) then c else '-'

{- Initialise the state with the missing letters in a word -}

total
letters : String -> List Char
letters x with (strM x)
  letters "" | StrNil = []
  letters (strCons y xs) | (StrCons y xs)
          = let xs' = assert_total (letters xs) in
                if ((not (isAlpha y)) || (y `elem` xs')) then xs' else y :: xs'

initState : (x : String) -> HState 6 (length (letters x))
initState w = let xs = letters w in
                  MkH w _ [] (fromList (letters w))

-----------------------------------------------------------------------
-- RULES
-----------------------------------------------------------------------

{- Now, the rules of the game, written as an Effect.
We can think of the rules as giving a protocol that the game player and
the machine must follow for an implementation of the game to make sense.
-}

data Hangman : Effect where

-- Rule:
-- Precondition: we can make a guess if we have one or more guess available
-- (S g) and one or more letters are still missing (S w)

-- Postcondition: return whether the character was in the word. If so, reduce
-- the number of missing letters, if not, reduce the number of guesses left

     Guess : (x : Char) ->
             { HState (S g) (S w) ==>
               {inword} if inword then HState (S g) w
                                  else HState g (S w) }
                Hangman Bool

-- The 'Won' operation requires that there are no missing letters

     Won  : { HState g 0 ==> HState 0 0 } Hangman ()

-- The 'Lost' operation requires that there are no guesses left

     Lost : { HState 0 w ==> HState 0 0 } Hangman ()

-- Set up a new game, initialised with 6 guesses and the missing letters in
-- the given word. Note that if there are no letters in the word, we won't
-- be able to run 'Guess'!

     NewWord : (w : String) ->
               { h ==> HState 6 (length (letters w)) } Hangman ()

-- Finally, allow us to get the current game state

     Get  : { h } Hangman h

HANGMAN : Nat -> Nat -> EFFECT
HANGMAN g v = MkEff (HState g v) Hangman

-----------------------------------------------------------------------
-- IMPLEMENTATION OF THE RULES
-----------------------------------------------------------------------

{- This effect handler simply updates the game state as necessary for
each operation. 'Guess' is slightly tricky, in that it needs to check
whether the letter is in the word, and branch accordingly (and if it
is in the word, update the vector of missing letters to be the right
length). -}

using (m : Type -> Type)
  instance Handler Hangman m where
    handle (MkH w g got []) Won k = k () (MkH w 0 got [])
    handle (MkH w Z got m) Lost k = k () (MkH w 0 got [])

    handle st Get k = k st st
    handle st (NewWord w) k = k () (initState w)

    handle (MkH w (S g) got m) (Guess x) k =
      case isElem x m of
           Nothing => k False (MkH w _ got m)
           (Just p) => k True (MkH w _ (x :: got) (shrink m p))

-----------------------------------------------------------------------
-- USER INTERFACE
-----------------------------------------------------------------------

{- Finally, an implementation of the game which reads user input and calls
the operations we defined above when appropriate -}

game : { [HANGMAN (S g) (S w), STDIO] ==> [HANGMAN 0 0, STDIO] } Eff IO ()
game = do putStrLn (show !Get)
          putStr "Enter guess: "
          let guess = trim !getStr
          case choose (not (guess == "")) of
               (Left p) => processGuess (strHead' guess p)
               (Right p) => do putStrLn "Invalid input!"
                               game
  where
    processGuess : Char -> { [HANGMAN (S g) (S w), STDIO] ==>
                             [HANGMAN 0 0, STDIO] }
                           Eff IO ()
    processGuess {g} {w} c
      = case !(Main.Guess c) of
             True => do putStrLn "Good guess!"
                        case w of
                             Z => Won
                             (S k) => game
             False => do putStrLn "No, sorry"
                         case g of
                              Z => Lost
                              (S k) => game

{- It typechecks! Ship it! -}

runGame : { [HANGMAN 0 0, STDIO] } Eff IO ()
runGame = do NewWord "sausage machine"
             game

{- I made a couple of mistakes while writing this. For example, the following
were caught by the type checker:

* Forgetting to check the 'Won' state before continuing with 'game'
* Accidentally checking the number of missing letters rather than the number
  of guesses when checking if 'Lost' was callable

-}

main : IO ()
main = run runGame


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

import System.Concurrency.Channels
import Chapter.Concurrency.ProcessLib

-- import Control.Arrow
-- import Control.Category
-- import Data.Morphisms

-- ------------------------------------ [ 15.1.1 Defining Concurrent Processes ]

%access public export

data Message = Add Nat Nat

-- ---------------------------------------- [ 15.1.2 Primitive Message Passing ]

namespace Unsafe

  %access export

  partial adder :IO ()
  adder = do Just chan <- listen 1
               | Nothing => adder
             Just msg <- unsafeRecv Message chan
               | Nothing => adder
             case msg of
                  Add x y => do ok <- unsafeSend chan (x + y)
                                adder

  partial main : IO ()
  main = do Just pid <- spawn adder
              | Nothing => putStrLn "Spawn failed"
            Just chan <- connect pid
              | Nothing => putStrLn "Connection failed"
            ok <- unsafeSend chan (Add 2 3)
            Just answer <- unsafeRecv Nat chan
              | Nothing => putStrLn "Receive failed"
            printLn answer

-- ----------------------------------- [ 15.2.1 Describing Processes in a Type ]

namespace Safe

  %access public export

  data MessagePID = MkMessage PID

  data Process : Type -> Type where
       Request : MessagePID -> Message -> Process (Maybe Nat)
       Respond : ((msg : Message) -> Process Nat) -> Process (Maybe Message)
       Spawn   : Process () -> Process (Maybe MessagePID)
       Loop    : Inf (Process a) -> Process a

       Action  : IO a -> Process a
       Pure    : a -> Process a
       (>>=)   : Process a -> (a -> Process b) -> Process b

  run : Fuel -> Process t -> IO (Maybe t)
  run Dry _                  = pure Nothing
  run fuel (Action act)      = pure (Just !act)
  run fuel (Pure val)        = pure (Just val)
  run fuel (act >>= next)    = do Just x <- run fuel act
                                    | Nothing => pure Nothing
                                  run fuel (next x)
  run (More fuel) (Loop act) = run fuel act
  run fuel (Spawn proc)   = do Just pid <- spawn (run fuel proc *> pure ())
                                 | Nothing => pure Nothing
                               pure (Just (Just (MkMessage pid)))
  -- TODO: encapsulate timeout
  run fuel (Respond calc) = do Just sender <- listen 1
                                 | Nothing => pure (Just Nothing)
                               Just msg <- unsafeRecv Message sender
                                 | Nothing => pure (Just Nothing)
                               Just res <- run fuel (calc msg)
                                 | Nothing => pure Nothing
                               unsafeSend sender res
                               pure (Just (Just msg))
  run fuel (Request (MkMessage proc) msg) =
      do Just chan <- connect proc
           | Nothing => pure (Just Nothing)
         if !(unsafeSend chan msg)
            then do Just x <- unsafeRecv Nat chan
                      | Nothing => pure (Just Nothing)
                    pure (Just (Just x))
            else pure (Just Nothing)

  partial runProc : Process () -> IO ()
  runProc proc = run forever proc *> pure ()

  adder : Process ()
  adder = do Respond go
             Loop adder
    where
      go : Message -> Process Nat
      go (Add x y) = Pure (x + y)

  partial main : Process ()
  main = do Just pid <- Spawn adder
              | Nothing => Action (putStrLn "Spawn failed")
            Just answer <- Request pid (Add 2 3)
              | Nothing => Action (putStrLn "Request failed")
            Action (printLn answer)

  -- NOTE: These two definitions type-check, but don't respond to messages.

  -- adderBad1 : Process ()
  -- adderBad1 = do Action $ putStrLn "I'm out of the office today"
  --                    Loop adderBad1

  -- adderBad2 : Process ()
  -- adderBad2 = Loop adderBad2

namespace Stateful

  -- data AdderAction : Type where
  --      Add : Nat -> Nat -> AdderAction

  public export
  AdderType : Message -> Type
  AdderType (Add x y) = Nat

  export
  adder : Service AdderType ()
  adder = do Respond (\(Add x y) => Pure (x + y))
             Loop adder

namespace ListProcessing

  %access public export

  data ListAction : Type where
       Length : List elem -> ListAction
       Append : List elem -> List elem -> ListAction

  ListType : ListAction -> Type
  ListType (Length xs)           = Nat
  ListType (Append {elem} xs ys) = List elem

  %access export

  procList : Service ListType ()
  procList = do Respond go
                Loop procList
    where
      go : (msg : ListAction) -> Process ListType (ListType msg) Ready Ready
      go (Length xs)    = Pure (length xs)
      go (Append xs ys) = Pure (xs ++ ys)

  procMain : Client ()
  procMain = do Just list <- Spawn procList
                  | Nothing => Action (putStrLn "Spawn failed")
                len <- Request list (Length [1,2,3])
                Action (printLn len)
                app <- Request list (Append [1,2,3] [4,5,6])
                Action (printLn app)

namespace WordCounting

  %access public export

  record WCData where
      constructor MkWCData
      wordCount : Nat
      lineCount : Nat

  implementation Show WCData where
    show (MkWCData wc lc) = unlines [ "Words: " ++ show wc
                                    , "Lines: " ++ show lc
                                    ]

  data WC = CountFile String
          | GetData String

  implementation Show WC where
    show (CountFile fname) = "CountFile " ++ fname
    show (GetData fname) = "GetData " ++ fname

  WCType : WC -> Type
  WCType (CountFile _) = ()
  WCType (GetData _)   = Maybe WCData

  private
  doCount : (content : String) -> WCData
  doCount content = MkWCData (length (lines content))
                             (length (words content))

  -- doCount' : (content : String) -> WCData
  -- doCount' = applyMor $ arrow (length . lines) &&&
  --                       arrow (length . words) >>>
  --                       arrow (uncurry MkWCData)

  countFile : List (String, WCData) -> String ->
              Process WCType (List (String, WCData)) Sent Sent
  countFile files fname =
      do Right content <- Action (readFile fname)
           | Left _ => Pure files
         let count = doCount content
         Action (putStrLn ("Counting complete for " ++ fname))
         Pure ((fname, doCount content) :: files)

  wcService : (loaded : List (String, WCData)) ->
              Service WCType ()
  wcService loaded =
      do msg <- Respond go
         newLoaded <- case msg of
              Just (CountFile fname) => countFile loaded fname
              _                      => Pure loaded
         Loop (wcService newLoaded)
    where
      go : (msg : WC) -> Process WCType (WCType msg) Ready Ready
      go (CountFile fname) = Pure ()
      go (GetData fname)   = Pure (lookup fname loaded)

  procMain : Client ()
  procMain =
      do Just wc <- Spawn (wcService [])
           | Nothing => Action (putStrLn "Spawn failed")
         Action (putStrLn "Counting test.txt")
         let fname = "/Users/mohacker/src/yurrriq/tdd-with-idris/README.org"
         Request wc (CountFile fname)
         Action (putStrLn "Processing")
         Just wcdata <- Request wc (GetData fname)
           | Nothing => Action (putStrLn "File error")
         Action (printLn wcdata)

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