idris-lang/Idris2
1
1
Fork 0
mirror of https://github.com/idris-lang/Idris2.git synced 2024-11-13 05:48:39 +03:00
Code Issues Projects Releases Wiki Activity

Merge pull request #316 from ohad/fancy-preorder-reasoning

Browse Source 
Fancy preorder reasoning
This commit is contained in:
Ohad Kammar 2020-06-20 22:47:25 +01:00 committed by GitHub
commit 59588a3f3a
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
2 changed files with 80 additions and 96 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

109
libs/contrib/Data/List/TailRec.idr
View File

@ -33,36 +33,25 @@ length xs = length_aux xs Z
export export
length_ext : (xs : List a) -> Data.List.length xs = Data.List.TailRec.length xs length_ext : (xs : List a) -> Data.List.length xs = Data.List.TailRec.length xs
length_ext xs = Calculate [ length_ext xs = Calc $
Data.List.length xs |~ Data.List.length xs
==| sym (plusZeroRightNeutral (Data.List.length xs)), ~~ Data.List.length xs + 0 ...( sym $ plusZeroRightNeutral $ Data.List.length xs )
Data.List.length xs + 0 ~~ Data.List.TailRec.length_aux xs 0 ...( lemma 0 xs )
==| lemma 0 xs, ~~ Data.List.TailRec.length xs ...( Refl )
Data.List.TailRec.length_aux xs 0
==| Refl,
Data.List.TailRec.length xs
==| QED
]
where where
lemma : (n : Nat) -> (xs : List a) -> lemma : (n : Nat) -> (xs : List a) ->
Data.List.length xs + n = length_aux xs n Data.List.length xs + n = length_aux xs n
lemma n [] = Refl lemma n [] = Refl
lemma n (_ :: xs) = lemma n (_ :: xs) =
let length_xs : Nat let length_xs : Nat
length_xs = Data.List.length xs in length_xs = Data.List.length xs in
Calculate [ Calc $
1 + (length_xs + n) |~ 1 + (length_xs + n)
-- Hopefully we could Frex these two steps one day -- Hopefully we could Frex these two steps one day
==| plusAssociative 1 length_xs n , ~~ (1 + length_xs) + n ...( plusAssociative 1 length_xs n )
(1 + length_xs) + n ~~ (length_xs + 1) + n ...( cong (+n) (plusCommutative 1 length_xs) )
==| cong (+n) (plusCommutative 1 length_xs) , ~~ (length_xs) + (1 + n) ...( sym (plusAssociative length_xs 1 n) )
(length_xs + 1) + n ~~ length_aux xs (1 + n) ...( lemma (1 + n) xs )
==| sym (plusAssociative length_xs 1 n),
(length_xs) + (1 + n)
==| lemma (1 + n) xs,
length_aux xs (1 + n)
==| QED
]
take_aux : Nat -> List a -> List a -> List a take_aux : Nat -> List a -> List a -> List a
take_aux Z xs acc = reverseOnto [] acc take_aux Z xs acc = reverseOnto [] acc
@ -77,16 +66,11 @@ export
take_ext : take_ext :
(n : Nat) -> (xs : List a) -> (n : Nat) -> (xs : List a) ->
Data.List.take n xs = Data.List.TailRec.take n xs Data.List.take n xs = Data.List.TailRec.take n xs
take_ext n xs = Calculate [ take_ext n xs = Calc $
Data.List.take n xs |~ Data.List.take n xs
==| Refl , ~~ reverse [] ++ (Data.List.take n xs) ...( Refl )
reverse [] ++ (Data.List.take n xs) ~~ reverseOnto (Data.List.take n xs) [] ...( sym (revOnto (Data.List.take n xs) []) )
==| sym (revOnto (Data.List.take n xs) []) , ~~ take_aux n xs [] ...( sym (lemma n xs []) )
reverseOnto (Data.List.take n xs) []
==| sym (lemma n xs []) ,
take_aux n xs []
==| QED
]
where where
lemma : (n : Nat) -> (xs, acc : List a) -> lemma : (n : Nat) -> (xs, acc : List a) ->
take_aux n xs acc = reverseOnto (Data.List.take n xs) acc take_aux n xs acc = reverseOnto (Data.List.take n xs) acc
@ -249,12 +233,10 @@ mergeReplicate_ext : (sep : a) -> (xs : List a) -> (acc : List a) ->
mergeReplicate_aux sep xs acc = mergeReplicate_aux sep xs acc =
reverseOnto (mergeReplicate sep xs) acc reverseOnto (mergeReplicate sep xs) acc
mergeReplicate_ext sep [] acc = Refl mergeReplicate_ext sep [] acc = Refl
mergeReplicate_ext sep (x::xs) acc = Calculate [ mergeReplicate_ext sep (x::xs) acc = Calc $
mergeReplicate_aux sep xs (x :: sep :: acc) |~ mergeReplicate_aux sep xs (x :: sep :: acc)
==| mergeReplicate_ext sep xs (x :: sep :: acc) , ~~ reverseOnto (sep :: x :: mergeReplicate sep xs) acc
reverseOnto (sep :: x :: mergeReplicate sep xs) acc ...( mergeReplicate_ext sep xs (x :: sep :: acc) )
==| QED
]
export export
intersperse : a -> List a -> List a intersperse : a -> List a -> List a
@ -314,9 +296,10 @@ mergeByOnto : List a -> (a -> a -> Ordering) -> List a -> List a -> List a
mergeByOnto acc order [] right = reverseOnto right acc mergeByOnto acc order [] right = reverseOnto right acc
mergeByOnto acc order left [] = reverseOnto left acc mergeByOnto acc order left [] = reverseOnto left acc
mergeByOnto acc order left@(x::xs) right@(y::ys) = mergeByOnto acc order left@(x::xs) right@(y::ys) =
case order x y of -- We need the variant annotations (bug #300)
LT => mergeByOnto (x :: acc) order xs right case order x y of
_ => mergeByOnto (y :: acc) order left ys LT => mergeByOnto (x :: acc) order (assert_smaller left xs) right
_ => mergeByOnto (y :: acc) order left (assert_smaller right ys)
mergeByOnto_ext : (acc : List a) mergeByOnto_ext : (acc : List a)
-> (order : a -> a -> Ordering) -> (order : a -> a -> Ordering)
@ -324,7 +307,9 @@ mergeByOnto_ext : (acc : List a)
-> reverseOnto (mergeBy order left right) acc -> reverseOnto (mergeBy order left right) acc
= mergeByOnto acc order left right = mergeByOnto acc order left right
mergeByOnto_ext acc order [] right = Refl mergeByOnto_ext acc order [] right = Refl
mergeByOnto_ext acc order left [] = ?bug139 mergeByOnto_ext acc order left [] with( left)
mergeByOnto_ext acc order _ [] | [] = Refl
mergeByOnto_ext acc order _ [] | (_::_) = Refl
mergeByOnto_ext acc order left@(x::xs) right@(y::ys) with (order x y) mergeByOnto_ext acc order left@(x::xs) right@(y::ys) with (order x y)
mergeByOnto_ext acc order left@(x::xs) right@(y::ys) | LT = mergeByOnto_ext acc order left@(x::xs) right@(y::ys) | LT =
mergeByOnto_ext (x :: acc) order xs (y::ys) mergeByOnto_ext (x :: acc) order xs (y::ys)
@ -368,27 +353,31 @@ export
sortBy : (cmp : a -> a -> Ordering) -> (xs : List a) -> List a sortBy : (cmp : a -> a -> Ordering) -> (xs : List a) -> List a
sortBy cmp [] = [] sortBy cmp [] = []
sortBy cmp [x] = [x] sortBy cmp [x] = [x]
sortBy cmp xs = let (x, y) = sortBy_split xs in sortBy cmp zs = let (xs, ys) = sortBy_split zs in
Data.List.TailRec.mergeBy cmp Data.List.TailRec.mergeBy cmp
(Data.List.TailRec.sortBy cmp (assert_smaller xs x)) (Data.List.TailRec.sortBy cmp (assert_smaller zs xs))
(Data.List.TailRec.sortBy cmp (assert_smaller xs y)) (Data.List.TailRec.sortBy cmp (assert_smaller zs ys))
{-- -- This code seems to make Idris2 loop {- Can't really finish this proof because Data.List doesn't export the definition of sortBy. -}
{-
export export
sortBy_ext : (cmp : a -> a -> Ordering) -> (xs : List a) -> sortBy_ext : (cmp : a -> a -> Ordering) -> (xs : List a) ->
Data.List.sortBy cmp xs = Data.List.TailRec.sortBy cmp xs Data.List.sortBy cmp xs = Data.List.TailRec.sortBy cmp xs
sortBy_ext cmp [] = Refl sortBy_ext cmp [] = Refl
sortBy_ext cmp [x] = Refl sortBy_ext cmp [x] = Refl
sortBy_ext cmp xs@(y::ys) = let (x, y) = split xs in sortBy_ext cmp zs'@(z::zs) =
Calculate [ Calc $
Data.List.mergeBy cmp |~ Data.List.sortBy cmp (z::zs)
(Data.List.sortBy cmp (assert_smaller xs x)) ~~ (let (xs, ys) = sortBy_split zs' in
(Data.List.sortBy cmp (assert_smaller xs y)) Data.List.mergeBy cmp
==| ?help1 , (Data.List.sortBy cmp xs)
(Data.List.sortBy cmp ys))
...( ?help0 )
~~
let (xs, ys) = sortBy_split (z::zs) in
Data.List.TailRec.mergeBy cmp Data.List.TailRec.mergeBy cmp
(Data.List.TailRec.sortBy cmp (assert_smaller xs x)) (Data.List.TailRec.sortBy cmp xs)
(Data.List.TailRec.sortBy cmp (assert_smaller xs y)) (Data.List.TailRec.sortBy cmp ys)
==| QED ...( ?help1 )
] -}
--}

67
libs/contrib/Syntax/PreorderReasoning.idr
View File

@ -1,42 +1,37 @@
||| Until Idris2 starts supporting the 'syntax' keyword, here's a ||| Until Idris2 starts supporting the 'syntax' keyword, here's a
||| poor-man's equational reasoning ||| poor-man's equational reasoning
module Syntax.PreorderReasoning module Syntax.PreorderReasoning
||| Deep embedding of equation derivation sequences. infixl 0 ~~
||| Using the Nil, (::) constructors lets us use list syntax. prefix 1 |~
infix 1 ...
|||Slightly nicer syntax for justifying equations:
|||```
||| |~ a
||| ~~ b ...( justification )
|||```
|||and we can think of the `...( justification )` as ASCII art for a thought bubble.
public export public export
data Derivation : (x : a) -> (y : b) -> Type where (...) : (x : a) -> (y ~=~ x) -> (z : a ** y ~=~ z)
Nil : Derivation x x (...) x pf = (x ** pf)
(::) : (x = y) -> Derivation y z -> Derivation x z
public export
data FastDerivation : (x : a) -> (y : b) -> Type where
(|~) : (x : a) -> FastDerivation x x
(~~) : FastDerivation x y -> (step : (z : c ** y ~=~ z)) -> FastDerivation x z
infix 1 ==| public export
Calc : {x : a} -> {y : b} -> FastDerivation x y -> x ~=~ y
Calc (|~ x) = Refl
Calc {y} ((~~) {z=y} {y=y} der (y ** Refl)) = Calc der
||| Explicate the term under consideration and the justification for {- -- requires import Data.Nat
||| the next step. 0
export
(==|) : (x : a) -> (x = y) -> x = y
(==|) x pf = pf
||| Finishg the derivation.
||| A bit klunky, but this /is/ a poor-man's version.
export
QED : {x : a} -> x = x
QED = Refl
export
Calculate : Derivation x y -> x = y
Calculate [] = Refl
Calculate (Refl :: der) = Calculate der
{--
||| Requires Data.Nata
example : (x : Nat) -> (x + 1) + 0 = 1 + x example : (x : Nat) -> (x + 1) + 0 = 1 + x
example x = Calculate [ example x =
(x + 1) + 0 Calc $
==| plusZeroRightNeutral (x + 1) , |~ (x + 1) + 0
x + 1 ~~ x+1 ...( plusZeroRightNeutral $ x + 1 )
==| plusCommutative x 1 , ~~ 1+x ...( plusCommutative x 1 )
1 + x -}
==| QED
]
--}