Mercurial > hg > GearsTemplate
diff src/parallel_execution/stack.agda @ 590:9146d6017f18 default tip
hg mv parallel_execution/* ..
author | anatofuz <anatofuz@cr.ie.u-ryukyu.ac.jp> |
---|---|
date | Thu, 16 Jan 2020 15:12:06 +0900 |
parents | a4cab67624f7 |
children |
line wrap: on
line diff
--- a/src/parallel_execution/stack.agda Thu Jan 16 15:11:11 2020 +0900 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,255 +0,0 @@ -open import Level renaming (suc to succ ; zero to Zero ) -module stack where - -open import Relation.Binary.PropositionalEquality -open import Relation.Binary.Core -open import Data.Nat - -ex : 1 + 2 ≡ 3 -ex = refl - -data Bool {n : Level } : Set n where - True : Bool - False : Bool - -record _∧_ {n : Level } (a : Set n) (b : Set n): Set n where - field - pi1 : a - pi2 : b - -data Maybe {n : Level } (a : Set n) : Set n where - Nothing : Maybe a - Just : a -> Maybe a - -record StackMethods {n m : Level } (a : Set n ) {t : Set m }(stackImpl : Set n ) : Set (m Level.⊔ n) where - field - push : stackImpl -> a -> (stackImpl -> t) -> t - pop : stackImpl -> (stackImpl -> Maybe a -> t) -> t - pop2 : stackImpl -> (stackImpl -> Maybe a -> Maybe a -> t) -> t - get : stackImpl -> (stackImpl -> Maybe a -> t) -> t - get2 : stackImpl -> (stackImpl -> Maybe a -> Maybe a -> t) -> t -open StackMethods - -record Stack {n m : Level } (a : Set n ) {t : Set m } (si : Set n ) : Set (m Level.⊔ n) where - field - stack : si - stackMethods : StackMethods {n} {m} a {t} si - pushStack : a -> (Stack a si -> t) -> t - pushStack d next = push (stackMethods ) (stack ) d (\s1 -> next (record {stack = s1 ; stackMethods = stackMethods } )) - popStack : (Stack a si -> Maybe a -> t) -> t - popStack next = pop (stackMethods ) (stack ) (\s1 d1 -> next (record {stack = s1 ; stackMethods = stackMethods }) d1 ) - pop2Stack : (Stack a si -> Maybe a -> Maybe a -> t) -> t - pop2Stack next = pop2 (stackMethods ) (stack ) (\s1 d1 d2 -> next (record {stack = s1 ; stackMethods = stackMethods }) d1 d2) - getStack : (Stack a si -> Maybe a -> t) -> t - getStack next = get (stackMethods ) (stack ) (\s1 d1 -> next (record {stack = s1 ; stackMethods = stackMethods }) d1 ) - get2Stack : (Stack a si -> Maybe a -> Maybe a -> t) -> t - get2Stack next = get2 (stackMethods ) (stack ) (\s1 d1 d2 -> next (record {stack = s1 ; stackMethods = stackMethods }) d1 d2) - -open Stack - -data Element {n : Level } (a : Set n) : Set n where - cons : a -> Maybe (Element a) -> Element a - -datum : {n : Level } {a : Set n} -> Element a -> a -datum (cons a _) = a - -next : {n : Level } {a : Set n} -> Element a -> Maybe (Element a) -next (cons _ n) = n - - -{- --- cannot define recrusive record definition. so use linked list with maybe. -record Element {l : Level} (a : Set n l) : Set n (suc l) where - field - datum : a -- `data` is reserved by Agda. - next : Maybe (Element a) --} - - - -record SingleLinkedStack {n : Level } (a : Set n) : Set n where - field - top : Maybe (Element a) -open SingleLinkedStack - -pushSingleLinkedStack : {n m : Level } {t : Set m } {Data : Set n} -> SingleLinkedStack Data -> Data -> (Code : SingleLinkedStack Data -> t) -> t -pushSingleLinkedStack stack datum next = next stack1 - where - element = cons datum (top stack) - stack1 = record {top = Just element} - - -popSingleLinkedStack : {n m : Level } {t : Set m } {a : Set n} -> SingleLinkedStack a -> (Code : SingleLinkedStack a -> (Maybe a) -> t) -> t -popSingleLinkedStack stack cs with (top stack) -... | Nothing = cs stack Nothing -... | Just d = cs stack1 (Just data1) - where - data1 = datum d - stack1 = record { top = (next d) } - -pop2SingleLinkedStack : {n m : Level } {t : Set m } {a : Set n} -> SingleLinkedStack a -> (Code : SingleLinkedStack a -> (Maybe a) -> (Maybe a) -> t) -> t -pop2SingleLinkedStack {n} {m} {t} {a} stack cs with (top stack) -... | Nothing = cs stack Nothing Nothing -... | Just d = pop2SingleLinkedStack' {n} {m} stack cs - where - pop2SingleLinkedStack' : {n m : Level } {t : Set m } -> SingleLinkedStack a -> (Code : SingleLinkedStack a -> (Maybe a) -> (Maybe a) -> t) -> t - pop2SingleLinkedStack' stack cs with (next d) - ... | Nothing = cs stack Nothing Nothing - ... | Just d1 = cs (record {top = (next d1)}) (Just (datum d)) (Just (datum d1)) - - -getSingleLinkedStack : {n m : Level } {t : Set m } {a : Set n} -> SingleLinkedStack a -> (Code : SingleLinkedStack a -> (Maybe a) -> t) -> t -getSingleLinkedStack stack cs with (top stack) -... | Nothing = cs stack Nothing -... | Just d = cs stack (Just data1) - where - data1 = datum d - -get2SingleLinkedStack : {n m : Level } {t : Set m } {a : Set n} -> SingleLinkedStack a -> (Code : SingleLinkedStack a -> (Maybe a) -> (Maybe a) -> t) -> t -get2SingleLinkedStack {n} {m} {t} {a} stack cs with (top stack) -... | Nothing = cs stack Nothing Nothing -... | Just d = get2SingleLinkedStack' {n} {m} stack cs - where - get2SingleLinkedStack' : {n m : Level} {t : Set m } -> SingleLinkedStack a -> (Code : SingleLinkedStack a -> (Maybe a) -> (Maybe a) -> t) -> t - get2SingleLinkedStack' stack cs with (next d) - ... | Nothing = cs stack Nothing Nothing - ... | Just d1 = cs stack (Just (datum d)) (Just (datum d1)) - - - -emptySingleLinkedStack : {n : Level } {a : Set n} -> SingleLinkedStack a -emptySingleLinkedStack = record {top = Nothing} - ------ --- Basic stack implementations are specifications of a Stack --- -singleLinkedStackSpec : {n m : Level } {t : Set m } {a : Set n} -> StackMethods {n} {m} a {t} (SingleLinkedStack a) -singleLinkedStackSpec = record { - push = pushSingleLinkedStack - ; pop = popSingleLinkedStack - ; pop2 = pop2SingleLinkedStack - ; get = getSingleLinkedStack - ; get2 = get2SingleLinkedStack - } - -createSingleLinkedStack : {n m : Level } {t : Set m } {a : Set n} -> Stack {n} {m} a {t} (SingleLinkedStack a) -createSingleLinkedStack = record { - stack = emptySingleLinkedStack ; - stackMethods = singleLinkedStackSpec - } - ----- --- --- proof of properties ( concrete cases ) --- - -test01 : {n : Level } {a : Set n} -> SingleLinkedStack a -> Maybe a -> Bool {n} -test01 stack _ with (top stack) -... | (Just _) = True -... | Nothing = False - - -test02 : {n : Level } {a : Set n} -> SingleLinkedStack a -> Bool -test02 stack = popSingleLinkedStack stack test01 - -test03 : {n : Level } {a : Set n} -> a -> Bool -test03 v = pushSingleLinkedStack emptySingleLinkedStack v test02 - --- after a push and a pop, the stack is empty -lemma : {n : Level} {A : Set n} {a : A} -> test03 a ≡ False -lemma = refl - -testStack01 : {n m : Level } {a : Set n} -> a -> Bool {m} -testStack01 v = pushStack createSingleLinkedStack v ( - \s -> popStack s (\s1 d1 -> True)) - --- after push 1 and 2, pop2 get 1 and 2 - -testStack02 : {m : Level } -> ( Stack ℕ (SingleLinkedStack ℕ) -> Bool {m} ) -> Bool {m} -testStack02 cs = pushStack createSingleLinkedStack 1 ( - \s -> pushStack s 2 cs) - - -testStack031 : (d1 d2 : ℕ ) -> Bool {Zero} -testStack031 2 1 = True -testStack031 _ _ = False - -testStack032 : (d1 d2 : Maybe ℕ) -> Bool {Zero} -testStack032 (Just d1) (Just d2) = testStack031 d1 d2 -testStack032 _ _ = False - -testStack03 : {m : Level } -> Stack ℕ (SingleLinkedStack ℕ) -> ((Maybe ℕ) -> (Maybe ℕ) -> Bool {m} ) -> Bool {m} -testStack03 s cs = pop2Stack s ( - \s d1 d2 -> cs d1 d2 ) - -testStack04 : Bool -testStack04 = testStack02 (\s -> testStack03 s testStack032) - -testStack05 : testStack04 ≡ True -testStack05 = refl - ------- --- --- proof of properties with indefinite state of stack --- --- this should be proved by properties of the stack inteface, not only by the implementation, --- and the implementation have to provides the properties. --- --- we cannot write "s ≡ s3", since level of the Set does not fit , but use stack s ≡ stack s3 is ok. --- anyway some implementations may result s != s3 --- - -stackInSomeState : {l m : Level } {D : Set l} {t : Set m } (s : SingleLinkedStack D ) -> Stack {l} {m} D {t} ( SingleLinkedStack D ) -stackInSomeState s = record { stack = s ; stackMethods = singleLinkedStackSpec } - -push->push->pop2 : {l : Level } {D : Set l} (x y : D ) (s : SingleLinkedStack D ) -> - pushStack ( stackInSomeState s ) x ( \s1 -> pushStack s1 y ( \s2 -> pop2Stack s2 ( \s3 y1 x1 -> (Just x ≡ x1 ) ∧ (Just y ≡ y1 ) ) )) -push->push->pop2 {l} {D} x y s = record { pi1 = refl ; pi2 = refl } - - -id : {n : Level} {A : Set n} -> A -> A -id a = a - --- push a, n times - -n-push : {n : Level} {A : Set n} {a : A} -> ℕ -> SingleLinkedStack A -> SingleLinkedStack A -n-push zero s = s -n-push {l} {A} {a} (suc n) s = pushSingleLinkedStack (n-push {l} {A} {a} n s) a (\s -> s ) - -n-pop : {n : Level}{A : Set n} {a : A} -> ℕ -> SingleLinkedStack A -> SingleLinkedStack A -n-pop zero s = s -n-pop {_} {A} {a} (suc n) s = popSingleLinkedStack (n-pop {_} {A} {a} n s) (\s _ -> s ) - -open ≡-Reasoning - -push-pop-equiv : {n : Level} {A : Set n} {a : A} (s : SingleLinkedStack A) -> (popSingleLinkedStack (pushSingleLinkedStack s a (\s -> s)) (\s _ -> s) ) ≡ s -push-pop-equiv s = refl - -push-and-n-pop : {n : Level} {A : Set n} {a : A} (n : ℕ) (s : SingleLinkedStack A) -> n-pop {_} {A} {a} (suc n) (pushSingleLinkedStack s a id) ≡ n-pop {_} {A} {a} n s -push-and-n-pop zero s = refl -push-and-n-pop {_} {A} {a} (suc n) s = begin - n-pop {_} {A} {a} (suc (suc n)) (pushSingleLinkedStack s a id) - ≡⟨ refl ⟩ - popSingleLinkedStack (n-pop {_} {A} {a} (suc n) (pushSingleLinkedStack s a id)) (\s _ -> s) - ≡⟨ cong (\s -> popSingleLinkedStack s (\s _ -> s )) (push-and-n-pop n s) ⟩ - popSingleLinkedStack (n-pop {_} {A} {a} n s) (\s _ -> s) - ≡⟨ refl ⟩ - n-pop {_} {A} {a} (suc n) s - ∎ - - -n-push-pop-equiv : {n : Level} {A : Set n} {a : A} (n : ℕ) (s : SingleLinkedStack A) -> (n-pop {_} {A} {a} n (n-push {_} {A} {a} n s)) ≡ s -n-push-pop-equiv zero s = refl -n-push-pop-equiv {_} {A} {a} (suc n) s = begin - n-pop {_} {A} {a} (suc n) (n-push (suc n) s) - ≡⟨ refl ⟩ - n-pop {_} {A} {a} (suc n) (pushSingleLinkedStack (n-push n s) a (\s -> s)) - ≡⟨ push-and-n-pop n (n-push n s) ⟩ - n-pop {_} {A} {a} n (n-push n s) - ≡⟨ n-push-pop-equiv n s ⟩ - s - ∎ - - -n-push-pop-equiv-empty : {n : Level} {A : Set n} {a : A} -> (n : ℕ) -> n-pop {_} {A} {a} n (n-push {_} {A} {a} n emptySingleLinkedStack) ≡ emptySingleLinkedStack -n-push-pop-equiv-empty n = n-push-pop-equiv n emptySingleLinkedStack