Mercurial > hg > Members > kono > Proof > automaton
changeset 183:3fa72793620b
fix
| author | Shinji KONO <kono@ie.u-ryukyu.ac.jp> |
|---|---|
| date | Sun, 13 Jun 2021 20:45:17 +0900 |
| parents | 567754463810 |
| children | a810ae49187c |
| files | automaton-in-agda/src/agda/automaton-ex.agda automaton-in-agda/src/agda/automaton.agda automaton-in-agda/src/agda/bijection.agda automaton-in-agda/src/agda/cfg.agda automaton-in-agda/src/agda/cfg1.agda automaton-in-agda/src/agda/chap0.agda automaton-in-agda/src/agda/derive.agda automaton-in-agda/src/agda/even.agda automaton-in-agda/src/agda/fin.agda automaton-in-agda/src/agda/finiteSet.agda automaton-in-agda/src/agda/finiteSetUtil.agda automaton-in-agda/src/agda/flcagl.agda automaton-in-agda/src/agda/gcd.agda automaton-in-agda/src/agda/halt.agda automaton-in-agda/src/agda/index.ind automaton-in-agda/src/agda/induction-ex.agda automaton-in-agda/src/agda/lang-text.agda automaton-in-agda/src/agda/logic.agda automaton-in-agda/src/agda/nfa.agda automaton-in-agda/src/agda/nfa136.agda automaton-in-agda/src/agda/non-regular.agda automaton-in-agda/src/agda/omega-automaton.agda automaton-in-agda/src/agda/prime.agda automaton-in-agda/src/agda/pushdown.agda automaton-in-agda/src/agda/puzzle.agda automaton-in-agda/src/agda/regex.agda automaton-in-agda/src/agda/regex1.agda automaton-in-agda/src/agda/regular-concat.agda automaton-in-agda/src/agda/regular-language.agda automaton-in-agda/src/agda/root2.agda automaton-in-agda/src/agda/sbconst2.agda automaton-in-agda/src/agda/turing.agda automaton-in-agda/src/agda/utm.agda automaton-in-agda/src/automaton-ex.agda automaton-in-agda/src/automaton.agda automaton-in-agda/src/bijection.agda automaton-in-agda/src/cfg.agda automaton-in-agda/src/cfg1.agda automaton-in-agda/src/chap0.agda automaton-in-agda/src/derive.agda automaton-in-agda/src/even.agda automaton-in-agda/src/fin.agda automaton-in-agda/src/finiteSet.agda automaton-in-agda/src/finiteSetUtil.agda automaton-in-agda/src/flcagl.agda automaton-in-agda/src/gcd.agda automaton-in-agda/src/halt.agda automaton-in-agda/src/index.ind automaton-in-agda/src/induction-ex.agda automaton-in-agda/src/lang-text.agda automaton-in-agda/src/logic.agda automaton-in-agda/src/nfa.agda automaton-in-agda/src/nfa136.agda automaton-in-agda/src/non-regular.agda automaton-in-agda/src/omega-automaton.agda automaton-in-agda/src/prime.agda automaton-in-agda/src/pushdown.agda automaton-in-agda/src/puzzle.agda automaton-in-agda/src/regex.agda automaton-in-agda/src/regex1.agda automaton-in-agda/src/regular-concat.agda automaton-in-agda/src/regular-language.agda automaton-in-agda/src/root2.agda automaton-in-agda/src/sbconst2.agda automaton-in-agda/src/turing.agda automaton-in-agda/src/utm.agda |
| diffstat | 66 files changed, 4616 insertions(+), 4616 deletions(-) [+] |
line wrap: on
line diff
--- a/automaton-in-agda/src/agda/automaton-ex.agda Sun Jun 13 18:48:57 2021 +0900 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,76 +0,0 @@ -module automaton-ex where - -open import Data.Nat -open import Data.List -open import Data.Maybe -open import Relation.Binary.PropositionalEquality hiding ( [_] ) -open import Relation.Nullary using (¬_; Dec; yes; no) -open import logic - -open import automaton -open Automaton - -data StatesQ : Set where - q1 : StatesQ - q2 : StatesQ - q3 : StatesQ - -data In2 : Set where - i0 : In2 - i1 : In2 -transitionQ : StatesQ → In2 → StatesQ -transitionQ q1 i0 = q1 -transitionQ q1 i1 = q2 -transitionQ q2 i0 = q3 -transitionQ q2 i1 = q2 -transitionQ q3 i0 = q2 -transitionQ q3 i1 = q2 - -aendQ : StatesQ → Bool -aendQ q2 = true -aendQ _ = false - -a1 : Automaton StatesQ In2 -a1 = record { - δ = transitionQ - ; aend = aendQ - } - -test1 : accept a1 q1 ( i0 ∷ i1 ∷ i0 ∷ [] ) ≡ false -test1 = refl -test2 = accept a1 q1 ( i0 ∷ i1 ∷ i0 ∷ i1 ∷ [] ) - -data States1 : Set where - sr : States1 - ss : States1 - st : States1 - -transition1 : States1 → In2 → States1 -transition1 sr i0 = sr -transition1 sr i1 = ss -transition1 ss i0 = sr -transition1 ss i1 = st -transition1 st i0 = sr -transition1 st i1 = st - -fin1 : States1 → Bool -fin1 st = true -fin1 ss = false -fin1 sr = false - -am1 : Automaton States1 In2 -am1 = record { δ = transition1 ; aend = fin1 } - - -example1-1 = accept am1 sr ( i0 ∷ i1 ∷ i0 ∷ [] ) -example1-2 = accept am1 sr ( i1 ∷ i1 ∷ i1 ∷ [] ) -trace-2 = trace am1 sr ( i1 ∷ i1 ∷ i1 ∷ [] ) - -example1-3 = reachable am1 sr st ( i1 ∷ i1 ∷ i1 ∷ [] ) - -ieq : (i i' : In2 ) → Dec ( i ≡ i' ) -ieq i0 i0 = yes refl -ieq i1 i1 = yes refl -ieq i0 i1 = no ( λ () ) -ieq i1 i0 = no ( λ () ) -
--- a/automaton-in-agda/src/agda/automaton.agda Sun Jun 13 18:48:57 2021 +0900 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,40 +0,0 @@ -module automaton where - -open import Data.Nat -open import Data.List -open import Relation.Binary.PropositionalEquality hiding ( [_] ) -open import logic - -record Automaton ( Q : Set ) ( Σ : Set ) - : Set where - field - δ : Q → Σ → Q - aend : Q → Bool - -open Automaton - -accept : { Q : Set } { Σ : Set } - → Automaton Q Σ - → (astart : Q) - → List Σ → Bool -accept {Q} { Σ} M q [] = aend M q -accept {Q} { Σ} M q ( H ∷ T ) = accept M ( (δ M) q H ) T - -moves : { Q : Set } { Σ : Set } - → Automaton Q Σ - → Q → List Σ → Q -moves {Q} { Σ} M q [] = q -moves {Q} { Σ} M q ( H ∷ T ) = moves M ( δ M q H) T - -trace : { Q : Set } { Σ : Set } - → Automaton Q Σ - → Q → List Σ → List Q -trace {Q} { Σ} M q [] = q ∷ [] -trace {Q} { Σ} M q ( H ∷ T ) = q ∷ trace M ( (δ M) q H ) T - -reachable : { Q : Set } { Σ : Set } - → (M : Automaton Q Σ ) - → (astart q : Q ) - → (L : List Σ ) → Set -reachable M astart q L = moves M astart L ≡ q -
--- a/automaton-in-agda/src/agda/bijection.agda Sun Jun 13 18:48:57 2021 +0900 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,180 +0,0 @@ -module bijection where - -open import Level renaming ( zero to Zero ; suc to Suc ) -open import Data.Nat -open import Data.Maybe -open import Data.List hiding ([_]) -open import Data.Nat.Properties -open import Relation.Nullary -open import Data.Empty -open import Data.Unit -open import Relation.Binary.Core hiding (_⇔_) -open import Relation.Binary.Definitions -open import Relation.Binary.PropositionalEquality - -open import logic - -record Bijection {n m : Level} (R : Set n) (S : Set m) : Set (n Level.⊔ m) where - field - fun← : S → R - fun→ : R → S - fiso← : (x : R) → fun← ( fun→ x ) ≡ x - fiso→ : (x : S ) → fun→ ( fun← x ) ≡ x - -injection : {n m : Level} (R : Set n) (S : Set m) (f : R → S ) → Set (n Level.⊔ m) -injection R S f = (x y : R) → f x ≡ f y → x ≡ y - -open Bijection - -b→injection0 : {n m : Level} (R : Set n) (S : Set m) → (b : Bijection R S) → injection R S (fun→ b) -b→injection0 R S b x y eq = begin - x - ≡⟨ sym ( fiso← b x ) ⟩ - fun← b ( fun→ b x ) - ≡⟨ cong (λ k → fun← b k ) eq ⟩ - fun← b ( fun→ b y ) - ≡⟨ fiso← b y ⟩ - y - ∎ where open ≡-Reasoning - -b→injection1 : {n m : Level} (R : Set n) (S : Set m) → (b : Bijection R S) → injection S R (fun← b) -b→injection1 R S b x y eq = trans ( sym ( fiso→ b x ) ) (trans ( cong (λ k → fun→ b k ) eq ) ( fiso→ b y )) - --- ¬ A = A → ⊥ - -diag : {S : Set } (b : Bijection ( S → Bool ) S) → S → Bool -diag b n = not (fun← b n n) - -diagonal : { S : Set } → ¬ Bijection ( S → Bool ) S -diagonal {S} b = diagn1 (fun→ b (diag b) ) refl where - diagn1 : (n : S ) → ¬ (fun→ b (diag b) ≡ n ) - diagn1 n dn = ¬t=f (diag b n ) ( begin - not (diag b n) - ≡⟨⟩ - not (not fun← b n n) - ≡⟨ cong (λ k → not (k n) ) (sym (fiso← b _)) ⟩ - not (fun← b (fun→ b (diag b)) n) - ≡⟨ cong (λ k → not (fun← b k n) ) dn ⟩ - not (fun← b n n) - ≡⟨⟩ - diag b n - ∎ ) where open ≡-Reasoning - -b1 : (b : Bijection ( ℕ → Bool ) ℕ) → ℕ -b1 b = fun→ b (diag b) - -b-iso : (b : Bijection ( ℕ → Bool ) ℕ) → fun← b (b1 b) ≡ (diag b) -b-iso b = fiso← b _ - -to1 : {n : Level} {R : Set n} → Bijection ℕ R → Bijection ℕ (⊤ ∨ R ) -to1 {n} {R} b = record { - fun← = to11 - ; fun→ = to12 - ; fiso← = to13 - ; fiso→ = to14 - } where - to11 : ⊤ ∨ R → ℕ - to11 (case1 tt) = 0 - to11 (case2 x) = suc ( fun← b x ) - to12 : ℕ → ⊤ ∨ R - to12 zero = case1 tt - to12 (suc n) = case2 ( fun→ b n) - to13 : (x : ℕ) → to11 (to12 x) ≡ x - to13 zero = refl - to13 (suc x) = cong suc (fiso← b x) - to14 : (x : ⊤ ∨ R) → to12 (to11 x) ≡ x - to14 (case1 x) = refl - to14 (case2 x) = cong case2 (fiso→ b x) - -open _∧_ - -open import nat - -open ≡-Reasoning - --- [] 0 --- 0 → 1 --- 1 → 2 --- 01 → 3 --- 11 → 4 --- ... --- -{-# TERMINATING #-} -LBℕ : Bijection ℕ ( List Bool ) -LBℕ = record { - fun← = λ x → lton x - ; fun→ = λ n → ntol n - ; fiso← = lbiso0 - ; fiso→ = lbisor - } where - lton1 : List Bool → ℕ - lton1 [] = 0 - lton1 (true ∷ t) = suc (lton1 t + lton1 t) - lton1 (false ∷ t) = lton1 t + lton1 t - lton : List Bool → ℕ - lton [] = 0 - lton x = suc (lton1 x) - ntol1 : ℕ → List Bool - ntol1 0 = [] - ntol1 (suc x) with div2 (suc x) - ... | ⟪ x1 , true ⟫ = true ∷ ntol1 x1 -- non terminating - ... | ⟪ x1 , false ⟫ = false ∷ ntol1 x1 - ntol : ℕ → List Bool - ntol 0 = [] - ntol 1 = false ∷ [] - ntol (suc n) = ntol1 n - xx : (x : ℕ ) → List Bool ∧ ℕ - xx x = ⟪ (ntol x) , lton ((ntol x)) ⟫ - add11 : (x1 : ℕ ) → suc x1 + suc x1 ≡ suc (suc (x1 + x1)) - add11 zero = refl - add11 (suc x) = cong (λ k → suc (suc k)) (trans (+-comm x _) (cong suc (+-comm _ x))) - add12 : (x1 x : ℕ ) → suc x1 + x ≡ x1 + suc x - add12 zero x = refl - add12 (suc x1) x = cong suc (add12 x1 x) - ---- div2-eq : (x : ℕ ) → div2-rev ( div2 x ) ≡ x - div20 : (x x1 : ℕ ) → div2 (suc x) ≡ ⟪ x1 , false ⟫ → x1 + x1 ≡ suc x - div20 x x1 eq = begin - x1 + x1 ≡⟨ cong (λ k → div2-rev k ) (sym eq) ⟩ - div2-rev (div2 (suc x)) ≡⟨ div2-eq _ ⟩ - suc x ∎ - div21 : (x x1 : ℕ ) → div2 (suc x) ≡ ⟪ x1 , true ⟫ → suc (x1 + x1) ≡ suc x - div21 x x1 eq = begin - suc (x1 + x1) ≡⟨ cong (λ k → div2-rev k ) (sym eq) ⟩ - div2-rev (div2 (suc x)) ≡⟨ div2-eq _ ⟩ - suc x ∎ - lbiso1 : (x : ℕ) → suc (lton1 (ntol1 x)) ≡ suc x - lbiso1 zero = refl - lbiso1 (suc x) with div2 (suc x) | inspect div2 (suc x) - ... | ⟪ x1 , true ⟫ | record { eq = eq1 } = begin - suc (suc (lton1 (ntol1 x1) + lton1 (ntol1 x1))) ≡⟨ sym (add11 _) ⟩ - suc (lton1 (ntol1 x1)) + suc (lton1 (ntol1 x1)) ≡⟨ cong ( λ k → k + k ) (lbiso1 x1) ⟩ - suc x1 + suc x1 ≡⟨ add11 x1 ⟩ - suc (suc (x1 + x1)) ≡⟨ cong suc (div21 x x1 eq1) ⟩ - suc (suc x) ∎ - ... | ⟪ x1 , false ⟫ | record { eq = eq1 } = begin - suc (lton1 (ntol1 x1) + lton1 (ntol1 x1)) ≡⟨ cong ( λ k → k + lton1 (ntol1 x1) ) (lbiso1 x1) ⟩ - suc x1 + lton1 (ntol1 x1) ≡⟨ add12 _ _ ⟩ - x1 + suc (lton1 (ntol1 x1)) ≡⟨ cong ( λ k → x1 + k ) (lbiso1 x1) ⟩ - x1 + suc x1 ≡⟨ +-comm x1 _ ⟩ - suc (x1 + x1) ≡⟨ cong suc (div20 x x1 eq1) ⟩ - suc (suc x) ∎ - lbiso0 : (x : ℕ) → lton (ntol x) ≡ x - lbiso0 zero = refl - lbiso0 (suc zero) = refl - lbiso0 (suc (suc x)) = subst (λ k → k ≡ suc (suc x)) (hh x) ( lbiso1 (suc x)) where - hh : (x : ℕ ) → suc (lton1 (ntol1 (suc x))) ≡ lton (ntol (suc (suc x))) - hh x with div2 (suc x) - ... | ⟪ _ , true ⟫ = refl - ... | ⟪ _ , false ⟫ = refl - lbisor0 : (x : List Bool) → ntol1 (lton1 (true ∷ x)) ≡ true ∷ x - lbisor0 = {!!} - lbisor1 : (x : List Bool) → ntol1 (lton1 (false ∷ x)) ≡ false ∷ x - lbisor1 = {!!} - lbisor : (x : List Bool) → ntol (lton x) ≡ x - lbisor [] = refl - lbisor (false ∷ []) = refl - lbisor (true ∷ []) = refl - lbisor (false ∷ t) = trans {!!} ( lbisor1 t ) - lbisor (true ∷ t) = trans {!!} ( lbisor0 t ) - -
--- a/automaton-in-agda/src/agda/cfg.agda Sun Jun 13 18:48:57 2021 +0900 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,134 +0,0 @@ -module cfg where - -open import Level renaming ( suc to succ ; zero to Zero ) -open import Data.Nat hiding ( _≟_ ) -open import Data.Fin -open import Data.Product -open import Data.List -open import Data.Maybe -open import Data.Bool using ( Bool ; true ; false ; _∧_ ; _∨_ ) -open import Relation.Binary.PropositionalEquality hiding ( [_] ) -open import Relation.Nullary using (¬_; Dec; yes; no) --- open import Data.String - -open import nfa - -data IsTerm (Token : Set) : Set where - isTerm : Token → IsTerm Token - noTerm : IsTerm Token - -record CFGGrammer (Token Node : Set) : Set (succ Zero) where - field - cfg : Node → List ( List ( Node ) ) - cfgtop : Node - term? : Node → IsTerm Token - tokensz : ℕ - tokenid : Token → Fin tokensz - -open CFGGrammer - ------------------ --- --- CGF language --- ------------------ - -split : {Σ : Set} → (List Σ → Bool) - → ( List Σ → Bool) → List Σ → Bool -split x y [] = x [] ∧ y [] -split x y (h ∷ t) = (x [] ∧ y (h ∷ t)) ∨ - split (λ t1 → x ( h ∷ t1 )) (λ t2 → y t2 ) t - - -cfg-language0 : {Node Token : Set} → CFGGrammer Token Node → List (List Node ) → List Token → Bool - -{-# TERMINATING #-} -cfg-language2 : {Node Token : Set} → CFGGrammer Token Node → Node → List Token → Bool -cfg-language2 cg _ [] = false -cfg-language2 cg x (h1 ∷ [] ) with term? cg x -cfg-language2 cg x (h1 ∷ []) | isTerm t with tokenid cg h1 ≟ tokenid cg t -cfg-language2 cg x (h1 ∷ []) | isTerm t | yes p = true -cfg-language2 cg x (h1 ∷ []) | isTerm t | no ¬p = false -cfg-language2 cg x (h1 ∷ []) | noTerm = cfg-language0 cg (cfg cg x) ( h1 ∷ [] ) -cfg-language2 cg x In with term? cg x -cfg-language2 cg x In | isTerm t = false -cfg-language2 cg x In | noTerm = cfg-language0 cg (cfg cg x ) In - -cfg-language1 : {Node Token : Set} → CFGGrammer Token Node → List Node → List Token → Bool -cfg-language1 cg [] [] = true -cfg-language1 cg [] _ = false -cfg-language1 cg (node ∷ T) = split ( cfg-language2 cg node ) ( cfg-language1 cg T ) - -cfg-language0 cg [] [] = true -cfg-language0 cg [] _ = false -cfg-language0 cg (node ∷ T) In = cfg-language1 cg node In ∨ cfg-language0 cg T In - -cfg-language : {Node Token : Set} → CFGGrammer Token Node → List Token → Bool -cfg-language cg = cfg-language0 cg (cfg cg (cfgtop cg)) - ------------------ - -data IFToken : Set where - t:EA : IFToken - t:EB : IFToken - t:EC : IFToken - t:IF : IFToken - t:THEN : IFToken - t:ELSE : IFToken - t:SA : IFToken - t:SB : IFToken - t:SC : IFToken - -IFtokenid : IFToken → Fin 9 -IFtokenid t:EA = # 0 -IFtokenid t:EB = # 1 -IFtokenid t:EC = # 2 -IFtokenid t:IF = # 3 -IFtokenid t:THEN = # 4 -IFtokenid t:ELSE = # 5 -IFtokenid t:SA = # 6 -IFtokenid t:SB = # 7 -IFtokenid t:SC = # 8 - -data IFNode (T : Set) : Set where - Token : T → IFNode T - expr : IFNode T - statement : IFNode T - -IFGrammer : CFGGrammer IFToken (IFNode IFToken) -IFGrammer = record { - cfg = cfg' - ; cfgtop = statement - ; term? = term?' - ; tokensz = 9 - ; tokenid = IFtokenid - } where - term?' : IFNode IFToken → IsTerm IFToken - term?' (Token x) = isTerm x - term?' _ = noTerm - cfg' : IFNode IFToken → List ( List (IFNode IFToken) ) - cfg' (Token t) = ( (Token t) ∷ [] ) ∷ [] - cfg' expr = ( Token t:EA ∷ [] ) ∷ - ( Token t:EB ∷ [] ) ∷ - ( Token t:EC ∷ [] ) ∷ [] - cfg' statement = ( Token t:SA ∷ [] ) ∷ - ( Token t:SB ∷ [] ) ∷ - ( Token t:SC ∷ [] ) ∷ - ( Token t:IF ∷ expr ∷ statement ∷ [] ) ∷ - ( Token t:IF ∷ expr ∷ statement ∷ Token t:ELSE ∷ statement ∷ [] ) ∷ [] - - -cfgtest1 = cfg-language IFGrammer ( t:SA ∷ [] ) - -cfgtest2 = cfg-language2 IFGrammer (Token t:SA) ( t:SA ∷ [] ) - -cfgtest3 = cfg-language1 IFGrammer (Token t:SA ∷ [] ) ( t:SA ∷ [] ) - -cfgtest4 = cfg-language IFGrammer (t:IF ∷ t:EA ∷ t:SA ∷ [] ) - -cfgtest5 = cfg-language1 IFGrammer (Token t:IF ∷ expr ∷ statement ∷ []) (t:IF ∷ t:EA ∷ t:EA ∷ [] ) -cfgtest6 = cfg-language2 IFGrammer statement (t:IF ∷ t:EA ∷ t:SA ∷ [] ) -cfgtest7 = cfg-language1 IFGrammer (Token t:IF ∷ expr ∷ statement ∷ Token t:ELSE ∷ statement ∷ []) (t:IF ∷ t:EA ∷ t:SA ∷ t:ELSE ∷ t:SB ∷ [] ) - -cfgtest8 = cfg-language IFGrammer (t:IF ∷ t:EA ∷ t:IF ∷ t:EB ∷ t:SA ∷ t:ELSE ∷ t:SB ∷ [] ) -
--- a/automaton-in-agda/src/agda/cfg1.agda Sun Jun 13 18:48:57 2021 +0900 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,184 +0,0 @@ -module cfg1 where - -open import Level renaming ( suc to succ ; zero to Zero ) -open import Data.Nat hiding ( _≟_ ) -open import Data.Fin -open import Data.Product -open import Data.List -open import Data.Maybe -open import Data.Bool using ( Bool ; true ; false ; _∧_ ; _∨_ ) -open import Relation.Binary.PropositionalEquality hiding ( [_] ) -open import Relation.Nullary using (¬_; Dec; yes; no) - --- --- Java → Java Byte Code --- --- CFG Stack Machine (PDA) --- - - -data Node (Symbol : Set) : Set where - T : Symbol → Node Symbol - N : Symbol → Node Symbol - -data Seq (Symbol : Set) : Set where - _，_ : Symbol → Seq Symbol → Seq Symbol - _． : Symbol → Seq Symbol - Error : Seq Symbol - -data Body (Symbol : Set) : Set where - _｜_ : Seq Symbol → Body Symbol → Body Symbol - _； : Seq Symbol → Body Symbol - -record CFGGrammer (Symbol : Set) : Set where - field - cfg : Symbol → Body Symbol - top : Symbol - eq? : Symbol → Symbol → Bool - typeof : Symbol → Node Symbol - -infixr 80 _｜_ -infixr 90 _； -infixr 100 _，_ -infixr 110 _． - -open CFGGrammer - ------------------ --- --- CGF language --- ------------------ - -split : {Σ : Set} → (List Σ → Bool) - → ( List Σ → Bool) → List Σ → Bool -split x y [] = x [] ∧ y [] -split x y (h ∷ t) = (x [] ∧ y (h ∷ t)) ∨ - split (λ t1 → x ( h ∷ t1 )) (λ t2 → y t2 ) t - - -cfg-language0 : {Symbol : Set} → CFGGrammer Symbol → Body Symbol → List Symbol → Bool - -{-# TERMINATING #-} -cfg-language1 : {Symbol : Set} → CFGGrammer Symbol → Seq Symbol → List Symbol → Bool -cfg-language1 cg Error x = false -cfg-language1 cg (S ， seq) x with typeof cg S -cfg-language1 cg (_ ， seq) (x' ∷ t) | T x = eq? cg x x' ∧ cfg-language1 cg seq t -cfg-language1 cg (_ ， seq) [] | T x = false -cfg-language1 cg (_ ， seq) x | N nonTerminal = split (cfg-language0 cg (cfg cg nonTerminal) )(cfg-language1 cg seq ) x -cfg-language1 cg (S ．) x with typeof cg S -cfg-language1 cg (_ ．) (x' ∷ []) | T x = eq? cg x x' -cfg-language1 cg (_ ．) _ | T x = false -cfg-language1 cg (_ ．) x | N nonTerminal = cfg-language0 cg (cfg cg nonTerminal) x - -cfg-language0 cg _ [] = false -cfg-language0 cg (rule ｜ b) x = - cfg-language1 cg rule x ∨ cfg-language0 cg b x -cfg-language0 cg (rule ；) x = cfg-language1 cg rule x - -cfg-language : {Symbol : Set} → CFGGrammer Symbol → List Symbol → Bool -cfg-language cg = cfg-language0 cg (cfg cg (top cg )) - - -data IFToken : Set where - EA : IFToken - EB : IFToken - EC : IFToken - IF : IFToken - THEN : IFToken - ELSE : IFToken - SA : IFToken - SB : IFToken - SC : IFToken - expr : IFToken - statement : IFToken - -token-eq? : IFToken → IFToken → Bool -token-eq? EA EA = true -token-eq? EB EB = true -token-eq? EC EC = true -token-eq? IF IF = true -token-eq? THEN THEN = true -token-eq? ELSE ELSE = true -token-eq? SA SA = true -token-eq? SB SB = true -token-eq? SC SC = true -token-eq? expr expr = true -token-eq? statement statement = true -token-eq? _ _ = false - -typeof-IFG : IFToken → Node IFToken -typeof-IFG expr = N expr -typeof-IFG statement = N statement -typeof-IFG x = T x - -IFGrammer : CFGGrammer IFToken -IFGrammer = record { - cfg = cfg' - ; top = statement - ; eq? = token-eq? - ; typeof = typeof-IFG - } where - cfg' : IFToken → Body IFToken - cfg' expr = EA ． ｜ EB ． ｜ EC ． ； - cfg' statement = - SA ． ｜ SB ． ｜ SC ． - ｜ IF ， expr ， THEN ， statement ． - ｜ IF ， expr ， THEN ， statement ， ELSE ， statement ． - ； - cfg' x = Error ； - -cfgtest1 = cfg-language IFGrammer ( SA ∷ [] ) - -cfgtest2 = cfg-language1 IFGrammer ( SA ．) ( SA ∷ [] ) - -cfgtest3 = cfg-language1 IFGrammer ( SA ． ) ( SA ∷ [] ) - -cfgtest4 = cfg-language IFGrammer (IF ∷ EA ∷ THEN ∷ SA ∷ [] ) - -cfgtest5 = cfg-language1 IFGrammer ( IF ， expr ， THEN ， statement ． ) (IF ∷ EA ∷ THEN ∷ SA ∷ [] ) -cfgtest6 = cfg-language1 IFGrammer ( statement ．)(IF ∷ EA ∷ SA ∷ [] ) -cfgtest7 = cfg-language1 IFGrammer ( IF ， expr ， THEN ， statement ， ELSE ， statement ． ) - (IF ∷ EA ∷ THEN ∷ SA ∷ ELSE ∷ SB ∷ [] ) -cfgtest8 = cfg-language IFGrammer (IF ∷ EA ∷ THEN ∷ IF ∷ EB ∷ THEN ∷ SA ∷ ELSE ∷ SB ∷ [] ) -cfgtest9 = cfg-language IFGrammer (IF ∷ EB ∷ THEN ∷ SA ∷ ELSE ∷ SB ∷ [] ) - -data E1Token : Set where - e1 : E1Token - e[ : E1Token - e] : E1Token - expr : E1Token - term : E1Token - -E1-token-eq? : E1Token → E1Token → Bool -E1-token-eq? e1 e1 = true -E1-token-eq? e[ e] = true -E1-token-eq? e] e] = true -E1-token-eq? expr expr = true -E1-token-eq? term term = true -E1-token-eq? _ _ = false - -typeof-E1 : E1Token → Node E1Token -typeof-E1 expr = N expr -typeof-E1 term = N term -typeof-E1 x = T x - -E1Grammer : CFGGrammer E1Token -E1Grammer = record { - cfg = cfgE - ; top = expr - ; eq? = E1-token-eq? - ; typeof = typeof-E1 - } where - cfgE : E1Token → Body E1Token - cfgE expr = term ． - ； - cfgE term = e1 ． - ｜ e[ ， expr ， e] ． - ； - cfgE x = Error ； - -ecfgtest1 = cfg-language E1Grammer ( e1 ∷ [] ) -ecfgtest2 = cfg-language E1Grammer ( e[ ∷ e1 ∷ e] ∷ [] ) -ecfgtest3 = cfg-language E1Grammer ( e[ ∷ e[ ∷ e1 ∷ e] ∷ e] ∷ [] ) -
--- a/automaton-in-agda/src/agda/chap0.agda Sun Jun 13 18:48:57 2021 +0900 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,210 +0,0 @@ -module chap0 where - -open import Data.List -open import Data.Nat hiding (_⊔_) --- open import Data.Integer hiding (_⊔_ ; _≟_ ; _+_ ) -open import Data.Product - -A : List ℕ -A = 1 ∷ 2 ∷ [] - -data Literal : Set where - x : Literal - y : Literal - z : Literal - -B : List Literal -B = x ∷ y ∷ z ∷ [] - - -ListProduct : {A B : Set } → List A → List B → List ( A × B ) -ListProduct = {!!} - -ex05 : List ( ℕ × Literal ) -ex05 = ListProduct A B -- (1 , x) ∷ (1 , y) ∷ (1 , z) ∷ (2 , x) ∷ (2 , y) ∷ (2 , z) ∷ [] - -ex06 : List ( ℕ × Literal × ℕ ) -ex06 = ListProduct A (ListProduct B A) - -ex07 : Set -ex07 = ℕ × ℕ - -data ex08-f : ℕ → ℕ → Set where - ex08f0 : ex08-f 0 1 - ex08f1 : ex08-f 1 2 - ex08f2 : ex08-f 2 3 - ex08f3 : ex08-f 3 4 - ex08f4 : ex08-f 4 0 - -data ex09-g : ℕ → ℕ → ℕ → ℕ → Set where - ex09g0 : ex09-g 0 1 2 3 - ex09g1 : ex09-g 1 2 3 0 - ex09g2 : ex09-g 2 3 0 1 - ex09g3 : ex09-g 3 0 1 2 - -open import Data.Nat.DivMod -open import Relation.Binary.PropositionalEquality -open import Relation.Binary.Core -open import Data.Nat.Properties - --- _%_ : ℕ → ℕ → ℕ --- _%_ a b with <-cmp a b --- _%_ a b | tri< a₁ ¬b ¬c = a --- _%_ a b | tri≈ ¬a b₁ ¬c = 0 --- _%_ a b | tri> ¬a ¬b c = _%_ (a - b) b - -_≡7_ : ℕ → ℕ → Set -n ≡7 m = (n % 7) ≡ (m % 7 ) - -refl7 : { n : ℕ} → n ≡7 n -refl7 = {!!} - -sym7 : { n m : ℕ} → n ≡7 m → m ≡7 n -sym7 = {!!} - -trans7 : { n m o : ℕ} → n ≡7 m → m ≡7 o → n ≡7 o -trans7 = {!!} - -open import Level renaming ( zero to Zero ; suc to Suc ) - -record Graph { v v' : Level } : Set (Suc v ⊔ Suc v' ) where - field - vertex : Set v - edge : vertex → vertex → Set v' - -open Graph - --- open import Data.Fin hiding ( _≟_ ) -open import Data.Empty -open import Relation.Nullary -open import Data.Unit hiding ( _≟_ ) - - --- data Dec (P : Set) : Set where --- yes : P → Dec P --- no : ¬ P → Dec P --- --- _≟_ : (s t : ℕ ) → Dec ( s ≡ t ) - --- ¬ A = A → ⊥ - -_n≟_ : (s t : ℕ ) → Dec ( s ≡ t ) -zero n≟ zero = yes refl -zero n≟ suc t = no (λ ()) -suc s n≟ zero = no (λ ()) -suc s n≟ suc t with s n≟ t -... | yes refl = yes refl -... | no n = no (λ k → n (tt1 k) ) where - tt1 : suc s ≡ suc t → s ≡ t - tt1 refl = refl - -open import Data.Bool hiding ( _≟_ ) - -conn : List ( ℕ × ℕ ) → ℕ → ℕ → Bool -conn [] _ _ = false -conn ((n1 , m1 ) ∷ t ) n m with n ≟ n1 | m ≟ m1 -conn ((n1 , m1) ∷ t) n m | yes refl | yes refl = true -conn ((n1 , m1) ∷ t) n m | _ | _ = conn t n m - -list012a : List ( ℕ × ℕ ) -list012a = (1 , 2) ∷ (2 , 3) ∷ (3 , 4) ∷ (4 , 5) ∷ (5 , 1) ∷ [] - -graph012a : Graph {Zero} {Zero} -graph012a = record { vertex = ℕ ; edge = λ s t → (conn list012a s t) ≡ true } - -data edge012b : ℕ → ℕ → Set where - e012b-1 : edge012b 1 2 - e012b-2 : edge012b 1 3 - e012b-3 : edge012b 1 4 - e012b-4 : edge012b 2 3 - e012b-5 : edge012b 2 4 - e012b-6 : edge012b 3 4 - -edge? : (E : ℕ → ℕ → Set) → ( a b : ℕ ) → Set -edge? E a b = Dec ( E a b ) - -lemma3 : ( a b : ℕ ) → edge? edge012b a b -lemma3 1 2 = yes e012b-1 -lemma3 1 3 = yes e012b-2 -lemma3 1 4 = yes e012b-3 -lemma3 2 3 = yes e012b-4 -lemma3 2 4 = yes e012b-5 -lemma3 3 4 = yes e012b-6 -lemma3 1 1 = no ( λ () ) -lemma3 2 1 = no ( λ () ) -lemma3 2 2 = no ( λ () ) -lemma3 3 1 = no ( λ () ) -lemma3 3 2 = no ( λ () ) -lemma3 3 3 = no ( λ () ) -lemma3 0 _ = no ( λ () ) -lemma3 _ 0 = no ( λ () ) -lemma3 _ (suc (suc (suc (suc (suc _))))) = no ( λ () ) -lemma3 (suc (suc (suc (suc _)))) _ = no ( λ () ) - -graph012b : Graph {Zero} {Zero} -graph012b = record { vertex = ℕ ; edge = edge012b } - -data connected { V : Set } ( E : V -> V -> Set ) ( x y : V ) : Set where - direct : E x y → connected E x y - indirect : ( z : V ) -> E x z → connected {V} E z y → connected E x y - -lemma1 : connected ( edge graph012a ) 1 2 -lemma1 = direct refl where - -lemma1-2 : connected ( edge graph012a ) 1 3 -lemma1-2 = indirect 2 refl (direct refl ) - -lemma2 : connected ( edge graph012b ) 1 2 -lemma2 = direct e012b-1 - -reachable : { V : Set } ( E : V -> V -> Set ) ( x y : V ) -> Set -reachable {V} E X Y = Dec ( connected {V} E X Y ) - -dag : { V : Set } ( E : V -> V -> Set ) -> Set -dag {V} E = ∀ (n : V) → ¬ ( connected E n n ) - -open import Function - -lemma4 : ¬ ( dag ( edge graph012a) ) -lemma4 neg = neg 1 $ indirect 2 refl $ indirect 3 refl $ indirect 4 refl $ indirect 5 refl $ direct refl - -dgree : List ( ℕ × ℕ ) → ℕ → ℕ -dgree [] _ = 0 -dgree ((e , e1) ∷ t) e0 with e0 ≟ e | e0 ≟ e1 -dgree ((e , e1) ∷ t) e0 | yes _ | _ = 1 + (dgree t e0) -dgree ((e , e1) ∷ t) e0 | _ | yes p = 1 + (dgree t e0) -dgree ((e , e1) ∷ t) e0 | no _ | no _ = dgree t e0 - -dgree-c : {t : Set} → List ( ℕ × ℕ ) → ℕ → (ℕ → t) → t -dgree-c {t} [] e0 next = next 0 -dgree-c {t} ((e , e1) ∷ tail ) e0 next with e0 ≟ e | e0 ≟ e1 -... | yes _ | _ = dgree-c tail e0 ( λ n → next (n + 1 )) -... | _ | yes _ = dgree-c tail e0 ( λ n → next (n + 1 )) -... | no _ | no _ = dgree-c tail e0 next - -lemma6 = dgree list012a 2 -lemma7 = dgree-c list012a 2 ( λ n → n ) - -even2 : (n : ℕ ) → n % 2 ≡ 0 → (n + 2) % 2 ≡ 0 -even2 0 refl = refl -even2 1 () -even2 (suc (suc n)) eq = trans ([a+n]%n≡a%n n _) eq -- [a+n]%n≡a%n : ∀ a n → (a + suc n) % suc n ≡ a % suc n - -sum-of-dgree : ( g : List ( ℕ × ℕ )) → ℕ -sum-of-dgree [] = 0 -sum-of-dgree ((e , e1) ∷ t) = 2 + sum-of-dgree t - -dgree-even : ( g : List ( ℕ × ℕ )) → sum-of-dgree g % 2 ≡ 0 -dgree-even [] = refl -dgree-even ((e , e1) ∷ t) = begin - sum-of-dgree ((e , e1) ∷ t) % 2 - ≡⟨⟩ - (2 + sum-of-dgree t ) % 2 - ≡⟨ cong ( λ k → k % 2 ) ( +-comm 2 (sum-of-dgree t) ) ⟩ - (sum-of-dgree t + 2) % 2 - ≡⟨ [a+n]%n≡a%n (sum-of-dgree t) _ ⟩ - sum-of-dgree t % 2 - ≡⟨ dgree-even t ⟩ - 0 - ∎ where open ≡-Reasoning -
--- a/automaton-in-agda/src/agda/derive.agda Sun Jun 13 18:48:57 2021 +0900 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,126 +0,0 @@ -{-# OPTIONS --allow-unsolved-metas #-} - -open import Relation.Binary.PropositionalEquality hiding ( [_] ) -open import Relation.Nullary using (¬_; Dec; yes; no) -open import Data.List hiding ( [_] ) - -module derive ( Σ : Set) ( eq? : (x y : Σ) → Dec (x ≡ y)) where - --- open import nfa -open import Data.Nat --- open import Data.Nat hiding ( _<_ ; _>_ ) --- open import Data.Fin hiding ( _<_ ) - -open import finiteSet -open import FSetUtil -open import automaton -open import logic -open import regex - -empty? : Regex Σ → Bool -empty? ε = true -empty? φ = false -empty? (x *) = true -empty? (x & y) = empty? x /\ empty? y -empty? (x || y) = empty? x \/ empty? y -empty? < x > = false - -derivative0 : Regex Σ → Σ → Regex Σ -derivative0 ε s = φ -derivative0 φ s = φ -derivative0 (x *) s = derivative0 x s & (x *) -derivative0 (x & y) s with empty? x -... | true = (derivative0 x s & y) || derivative0 y s -... | false = derivative0 x s & y -derivative0 (x || y) s = derivative0 x s || derivative0 y s -derivative0 < x > s with eq? x s -... | yes _ = ε -... | no _ = φ - -derivative : Regex Σ → Σ → Regex Σ -derivative ε s = φ -derivative φ s = φ -derivative (x *) s with derivative x s -... | ε = x * -... | φ = φ -... | t = t & (x *) -derivative (x & y) s with empty? x -... | true with derivative x s | derivative y s -... | ε | φ = φ -... | ε | t = y || t -... | φ | t = t -... | x1 | φ = x1 & y -... | x1 | y1 = (x1 & y) || y1 -derivative (x & y) s | false with derivative x s -... | ε = y -... | φ = φ -... | t = t & y -derivative (x || y) s with derivative x s | derivative y s -... | φ | y1 = y1 -... | x1 | φ = x1 -... | x1 | y1 = x1 || y1 -derivative < x > s with eq? x s -... | yes _ = ε -... | no _ = φ - -data regex-states (x : Regex Σ ) : Regex Σ → Set where - unit : regex-states x x - derive : { y : Regex Σ } → regex-states x y → (s : Σ) → regex-states x ( derivative y s ) - -record Derivative (x : Regex Σ ) : Set where - field - state : Regex Σ - is-derived : regex-states x state - -open Derivative - -open import Data.Fin - --- derivative generates (x & y) || ... form. y and x part is a substerm of original regex --- since subterm is finite, only finite number of state is negerated, if we normalize ||-list. - -data subterm (r : Regex Σ) : Regex Σ → Set where - sε : subterm r ε - sφ : subterm r φ - orig : subterm r r - x& : {x y : Regex Σ } → subterm r (x & y) → subterm r x - &y : {x y : Regex Σ } → subterm r (x & y) → subterm r y - x| : {x y : Regex Σ } → subterm r (x || y) → subterm r x - |y : {x y : Regex Σ } → subterm r (x || y) → subterm r y - s* : {x : Regex Σ } → subterm r (x *) → subterm r x - s<_> : (s : Σ) → subterm r < s > → subterm r < s > - -record Subterm (r : Regex Σ) : Set where - field - subt : Regex Σ - is-subt : subterm r subt - -finsub : (r : Regex Σ ) → FiniteSet (Subterm r) -finsub ε = {!!} -finsub φ = {!!} -finsub (r *) = {!!} -finsub (r & r₁) = {!!} -finsub (r || r₁) = {!!} -finsub < x > = {!!} - -finsubList : (r : Regex Σ ) → FiniteSet (Subterm r ∧ Subterm r → Bool ) -finsubList r = fin→ ( fin-∧ (finsub r) (finsub r) ) - --- derivative is subset of Subterm r → Subterm r → Bool - -der2ssb : {r : Regex Σ } → Derivative r → Subterm r ∧ Subterm r → Bool -der2ssb = {!!} - --- we cannot say this, because Derivative is redundant --- der2inject : {r : Regex Σ } → (x y : Derivative r ) → ( ( s t : Subterm r ∧ Subterm r ) → der2ssb x s ≡ der2ssb y t ) → x ≡ y - --- this does not work, becuase it depends on input sequences --- finite-derivative : (r : Regex Σ) → FiniteSet Σ → FiniteSet (Derivative r) - --- in case of automaton, number of derivative is limited by iteration of input length, so it is finite. - -regex→automaton : (r : Regex Σ) → Automaton (Derivative r) Σ -regex→automaton r = record { δ = λ d s → record { state = derivative (state d) s ; is-derived = derive-step d s} ; aend = λ d → empty? (state d) } where - derive-step : (d0 : Derivative r) → (s : Σ) → regex-states r (derivative (state d0) s) - derive-step d0 s = derive (is-derived d0) s -
--- a/automaton-in-agda/src/agda/even.agda Sun Jun 13 18:48:57 2021 +0900 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,71 +0,0 @@ -module even where - -open import Data.Nat -open import Data.Nat.Properties -open import Data.Empty -open import Data.Unit using (⊤ ; tt) -open import Relation.Nullary -open import Relation.Binary.PropositionalEquality -open import Relation.Binary.Definitions -open import nat -open import logic - -even : (n : ℕ ) → Set -even zero = ⊤ -even (suc zero) = ⊥ -even (suc (suc n)) = even n - -even? : (n : ℕ ) → Dec ( even n ) -even? zero = yes tt -even? (suc zero) = no (λ ()) -even? (suc (suc n)) = even? n - -n+even : {n m : ℕ } → even n → even m → even ( n + m ) -n+even {zero} {zero} tt tt = tt -n+even {zero} {suc m} tt em = em -n+even {suc (suc n)} {m} en em = n+even {n} {m} en em - -n*even : {m n : ℕ } → even n → even ( m * n ) -n*even {zero} {n} en = tt -n*even {suc m} {n} en = n+even {n} {m * n} en (n*even {m} {n} en) - -even*n : {n m : ℕ } → even n → even ( n * m ) -even*n {n} {m} en = subst even (*-comm m n) (n*even {m} {n} en) - - -record Even (i : ℕ) : Set where - field - j : ℕ - is-twice : i ≡ 2 * j - -e2 : (i : ℕ) → even i → Even i -e2 zero en = record { j = 0 ; is-twice = refl } -e2 (suc (suc i)) en = record { j = suc (Even.j (e2 i en )) ; is-twice = e21 } where - e21 : suc (suc i) ≡ 2 * suc (Even.j (e2 i en)) - e21 = begin - suc (suc i) ≡⟨ cong (λ k → suc (suc k)) (Even.is-twice (e2 i en)) ⟩ - suc (suc (2 * Even.j (e2 i en))) ≡⟨ sym (*-distribˡ-+ 2 1 _) ⟩ - 2 * suc (Even.j (e2 i en)) ∎ where open ≡-Reasoning - -record Odd (i : ℕ) : Set where - field - j : ℕ - is-twice : i ≡ suc (2 * j ) - -odd2 : (i : ℕ) → ¬ even i → even (suc i) -odd2 zero ne = ⊥-elim ( ne tt ) -odd2 (suc zero) ne = tt -odd2 (suc (suc i)) ne = odd2 i ne - -odd3 : (i : ℕ) → ¬ even i → Odd i -odd3 zero ne = ⊥-elim ( ne tt ) -odd3 (suc zero) ne = record { j = 0 ; is-twice = refl } -odd3 (suc (suc i)) ne = record { j = Even.j (e2 (suc i) (odd2 i ne)) ; is-twice = odd31 } where - odd31 : suc (suc i) ≡ suc (2 * Even.j (e2 (suc i) (odd2 i ne))) - odd31 = begin - suc (suc i) ≡⟨ cong suc (Even.is-twice (e2 (suc i) (odd2 i ne))) ⟩ - suc (2 * (Even.j (e2 (suc i) (odd2 i ne)))) ∎ where open ≡-Reasoning - -odd4 : (i : ℕ) → even i → ¬ even ( suc i ) -odd4 (suc (suc i)) en en1 = odd4 i en en1 -
--- a/automaton-in-agda/src/agda/fin.agda Sun Jun 13 18:48:57 2021 +0900 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,117 +0,0 @@ -{-# OPTIONS --allow-unsolved-metas #-} - -module fin where - -open import Data.Fin hiding (_<_ ; _≤_ ) -open import Data.Fin.Properties hiding ( <-trans ) -open import Data.Nat -open import logic -open import nat -open import Relation.Binary.PropositionalEquality - - --- toℕ<n -fin<n : {n : ℕ} {f : Fin n} → toℕ f < n -fin<n {_} {zero} = s≤s z≤n -fin<n {suc n} {suc f} = s≤s (fin<n {n} {f}) - --- toℕ≤n -fin≤n : {n : ℕ} (f : Fin (suc n)) → toℕ f ≤ n -fin≤n {_} zero = z≤n -fin≤n {suc n} (suc f) = s≤s (fin≤n {n} f) - -pred<n : {n : ℕ} {f : Fin (suc n)} → n > 0 → Data.Nat.pred (toℕ f) < n -pred<n {suc n} {zero} (s≤s z≤n) = s≤s z≤n -pred<n {suc n} {suc f} (s≤s z≤n) = fin<n - -fin<asa : {n : ℕ} → toℕ (fromℕ< {n} a<sa) ≡ n -fin<asa = toℕ-fromℕ< nat.a<sa - --- fromℕ<-toℕ -toℕ→from : {n : ℕ} {x : Fin (suc n)} → toℕ x ≡ n → fromℕ n ≡ x -toℕ→from {0} {zero} refl = refl -toℕ→from {suc n} {suc x} eq = cong (λ k → suc k ) ( toℕ→from {n} {x} (cong (λ k → Data.Nat.pred k ) eq )) - -0≤fmax : {n : ℕ } → (# 0) Data.Fin.≤ fromℕ< {n} a<sa -0≤fmax = subst (λ k → 0 ≤ k ) (sym (toℕ-fromℕ< a<sa)) z≤n - -0<fmax : {n : ℕ } → (# 0) Data.Fin.< fromℕ< {suc n} a<sa -0<fmax = subst (λ k → 0 < k ) (sym (toℕ-fromℕ< a<sa)) (s≤s z≤n) - --- toℕ-injective -i=j : {n : ℕ} (i j : Fin n) → toℕ i ≡ toℕ j → i ≡ j -i=j {suc n} zero zero refl = refl -i=j {suc n} (suc i) (suc j) eq = cong ( λ k → suc k ) ( i=j i j (cong ( λ k → Data.Nat.pred k ) eq) ) - --- raise 1 -fin+1 : { n : ℕ } → Fin n → Fin (suc n) -fin+1 zero = zero -fin+1 (suc x) = suc (fin+1 x) - -open import Data.Nat.Properties as NatP hiding ( _≟_ ) - -fin+1≤ : { i n : ℕ } → (a : i < n) → fin+1 (fromℕ< a) ≡ fromℕ< (<-trans a a<sa) -fin+1≤ {0} {suc i} (s≤s z≤n) = refl -fin+1≤ {suc n} {suc (suc i)} (s≤s (s≤s a)) = cong (λ k → suc k ) ( fin+1≤ {n} {suc i} (s≤s a) ) - -fin+1-toℕ : { n : ℕ } → { x : Fin n} → toℕ (fin+1 x) ≡ toℕ x -fin+1-toℕ {suc n} {zero} = refl -fin+1-toℕ {suc n} {suc x} = cong (λ k → suc k ) (fin+1-toℕ {n} {x}) - -open import Relation.Nullary -open import Data.Empty - -fin-1 : { n : ℕ } → (x : Fin (suc n)) → ¬ (x ≡ zero ) → Fin n -fin-1 zero ne = ⊥-elim (ne refl ) -fin-1 {n} (suc x) ne = x - -fin-1-sx : { n : ℕ } → (x : Fin n) → fin-1 (suc x) (λ ()) ≡ x -fin-1-sx zero = refl -fin-1-sx (suc x) = refl - -fin-1-xs : { n : ℕ } → (x : Fin (suc n)) → (ne : ¬ (x ≡ zero )) → suc (fin-1 x ne ) ≡ x -fin-1-xs zero ne = ⊥-elim ( ne refl ) -fin-1-xs (suc x) ne = refl - --- suc-injective --- suc-eq : {n : ℕ } {x y : Fin n} → Fin.suc x ≡ Fin.suc y → x ≡ y --- suc-eq {n} {x} {y} eq = subst₂ (λ j k → j ≡ k ) {!!} {!!} (cong (λ k → Data.Fin.pred k ) eq ) - --- this is refl -lemma3 : {a b : ℕ } → (lt : a < b ) → fromℕ< (s≤s lt) ≡ suc (fromℕ< lt) -lemma3 (s≤s lt) = refl - --- fromℕ<-toℕ -lemma12 : {n m : ℕ } → (n<m : n < m ) → (f : Fin m ) → toℕ f ≡ n → f ≡ fromℕ< n<m -lemma12 {zero} {suc m} (s≤s z≤n) zero refl = refl -lemma12 {suc n} {suc m} (s≤s n<m) (suc f) refl = cong suc ( lemma12 {n} {m} n<m f refl ) - -open import Relation.Binary.HeterogeneousEquality as HE using (_≅_ ) -open import Data.Fin.Properties - --- <-irrelevant -<-nat=irr : {i j n : ℕ } → ( i ≡ j ) → {i<n : i < n } → {j<n : j < n } → i<n ≅ j<n -<-nat=irr {zero} {zero} {suc n} refl {s≤s z≤n} {s≤s z≤n} = HE.refl -<-nat=irr {suc i} {suc i} {suc n} refl {s≤s i<n} {s≤s j<n} = HE.cong (λ k → s≤s k ) ( <-nat=irr {i} {i} {n} refl ) - -lemma8 : {i j n : ℕ } → ( i ≡ j ) → {i<n : i < n } → {j<n : j < n } → i<n ≅ j<n -lemma8 {zero} {zero} {suc n} refl {s≤s z≤n} {s≤s z≤n} = HE.refl -lemma8 {suc i} {suc i} {suc n} refl {s≤s i<n} {s≤s j<n} = HE.cong (λ k → s≤s k ) ( lemma8 {i} {i} {n} refl ) - --- fromℕ<-irrelevant -lemma10 : {n i j : ℕ } → ( i ≡ j ) → {i<n : i < n } → {j<n : j < n } → fromℕ< i<n ≡ fromℕ< j<n -lemma10 {n} refl = HE.≅-to-≡ (HE.cong (λ k → fromℕ< k ) (lemma8 refl )) - -lemma31 : {a b c : ℕ } → { a<b : a < b } { b<c : b < c } { a<c : a < c } → NatP.<-trans a<b b<c ≡ a<c -lemma31 {a} {b} {c} {a<b} {b<c} {a<c} = HE.≅-to-≡ (lemma8 refl) - --- toℕ-fromℕ< -lemma11 : {n m : ℕ } {x : Fin n } → (n<m : n < m ) → toℕ (fromℕ< (NatP.<-trans (toℕ<n x) n<m)) ≡ toℕ x -lemma11 {n} {m} {x} n<m = begin - toℕ (fromℕ< (NatP.<-trans (toℕ<n x) n<m)) - ≡⟨ toℕ-fromℕ< _ ⟩ - toℕ x - ∎ where - open ≡-Reasoning - -
--- a/automaton-in-agda/src/agda/finiteSet.agda Sun Jun 13 18:48:57 2021 +0900 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,42 +0,0 @@ -{-# OPTIONS --allow-unsolved-metas #-} -module finiteSet where - -open import Data.Nat hiding ( _≟_ ) -open import Data.Fin renaming ( _<_ to _<<_ ) hiding (_≤_) --- open import Data.Fin.Properties -open import Data.Empty -open import Relation.Nullary -open import Relation.Binary.Definitions -open import Relation.Binary.PropositionalEquality -open import logic -open import nat -open import Data.Nat.Properties hiding ( _≟_ ) - -open import Relation.Binary.HeterogeneousEquality as HE using (_≅_ ) - -record FiniteSet ( Q : Set ) : Set where - field - finite : ℕ - Q←F : Fin finite → Q - F←Q : Q → Fin finite - finiso→ : (q : Q) → Q←F ( F←Q q ) ≡ q - finiso← : (f : Fin finite ) → F←Q ( Q←F f ) ≡ f - exists1 : (m : ℕ ) → m Data.Nat.≤ finite → (Q → Bool) → Bool - exists1 zero _ _ = false - exists1 ( suc m ) m<n p = p (Q←F (fromℕ< {m} {finite} m<n)) \/ exists1 m (≤to< m<n) p - exists : ( Q → Bool ) → Bool - exists p = exists1 finite ≤-refl p - - open import Data.List - list1 : (m : ℕ ) → m Data.Nat.≤ finite → (Q → Bool) → List Q - list1 zero _ _ = [] - list1 ( suc m ) m<n p with bool-≡-? (p (Q←F (fromℕ< {m} {finite} m<n))) true - ... | yes _ = Q←F (fromℕ< {m} {finite} m<n) ∷ list1 m (≤to< m<n) p - ... | no _ = list1 m (≤to< m<n) p - to-list : ( Q → Bool ) → List Q - to-list p = list1 finite ≤-refl p - - equal? : Q → Q → Bool - equal? q0 q1 with F←Q q0 ≟ F←Q q1 - ... | yes p = true - ... | no ¬p = false
--- a/automaton-in-agda/src/agda/finiteSetUtil.agda Sun Jun 13 18:48:57 2021 +0900 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,461 +0,0 @@ -{-# OPTIONS --allow-unsolved-metas #-} - -module finiteSetUtil where - -open import Data.Nat hiding ( _≟_ ) -open import Data.Fin renaming ( _<_ to _<<_ ) hiding (_≤_) -open import Data.Fin.Properties -open import Data.Empty -open import Relation.Nullary -open import Relation.Binary.Definitions -open import Relation.Binary.PropositionalEquality -open import logic -open import nat -open import finiteSet -open import fin -open import Data.Nat.Properties as NatP hiding ( _≟_ ) -open import Relation.Binary.HeterogeneousEquality as HE using (_≅_ ) - -record Found ( Q : Set ) (p : Q → Bool ) : Set where - field - found-q : Q - found-p : p found-q ≡ true - -module _ {Q : Set } (F : FiniteSet Q) where - open FiniteSet F - equal→refl : { x y : Q } → equal? x y ≡ true → x ≡ y - equal→refl {q0} {q1} eq with F←Q q0 ≟ F←Q q1 - equal→refl {q0} {q1} refl | yes eq = begin - q0 - ≡⟨ sym ( finiso→ q0) ⟩ - Q←F (F←Q q0) - ≡⟨ cong (λ k → Q←F k ) eq ⟩ - Q←F (F←Q q1) - ≡⟨ finiso→ q1 ⟩ - q1 - ∎ where open ≡-Reasoning - End : (m : ℕ ) → (p : Q → Bool ) → Set - End m p = (i : Fin finite) → m ≤ toℕ i → p (Q←F i ) ≡ false - first-end : ( p : Q → Bool ) → End finite p - first-end p i i>n = ⊥-elim (nat-≤> i>n (fin<n {finite} {i}) ) - next-end : {m : ℕ } → ( p : Q → Bool ) → End (suc m) p - → (m<n : m < finite ) → p (Q←F (fromℕ< m<n )) ≡ false - → End m p - next-end {m} p prev m<n np i m<i with NatP.<-cmp m (toℕ i) - next-end p prev m<n np i m<i | tri< a ¬b ¬c = prev i a - next-end p prev m<n np i m<i | tri> ¬a ¬b c = ⊥-elim ( nat-≤> m<i c ) - next-end {m} p prev m<n np i m<i | tri≈ ¬a b ¬c = subst ( λ k → p (Q←F k) ≡ false) (m<n=i i b m<n ) np where - m<n=i : {n : ℕ } (i : Fin n) {m : ℕ } → m ≡ (toℕ i) → (m<n : m < n ) → fromℕ< m<n ≡ i - m<n=i i eq m<n = {!!} -- toℕ-inject (fromℕ≤ ?) i (subst (λ k → k ≡ toℕ i) (sym (toℕ-fromℕ≤ m<n)) eq ) - found : { p : Q → Bool } → (q : Q ) → p q ≡ true → exists p ≡ true - found {p} q pt = found1 finite (NatP.≤-refl ) ( first-end p ) where - found1 : (m : ℕ ) (m<n : m Data.Nat.≤ finite ) → ((i : Fin finite) → m ≤ toℕ i → p (Q←F i ) ≡ false ) → exists1 m m<n p ≡ true - found1 0 m<n end = ⊥-elim ( ¬-bool (subst (λ k → k ≡ false ) (cong (λ k → p k) (finiso→ q) ) (end (F←Q q) z≤n )) pt ) - found1 (suc m) m<n end with bool-≡-? (p (Q←F (fromℕ< m<n))) true - found1 (suc m) m<n end | yes eq = subst (λ k → k \/ exists1 m (≤to< m<n) p ≡ true ) (sym eq) (bool-or-4 {exists1 m (≤to< m<n) p} ) - found1 (suc m) m<n end | no np = begin - p (Q←F (fromℕ< m<n)) \/ exists1 m (≤to< m<n) p - ≡⟨ bool-or-1 (¬-bool-t np ) ⟩ - exists1 m (≤to< m<n) p - ≡⟨ found1 m (≤to< m<n) (next-end p end m<n (¬-bool-t np )) ⟩ - true - ∎ where open ≡-Reasoning - - - -record ISO (A B : Set) : Set where - field - A←B : B → A - B←A : A → B - iso← : (q : A) → A←B ( B←A q ) ≡ q - iso→ : (f : B) → B←A ( A←B f ) ≡ f - -iso-fin : {A B : Set} → FiniteSet A → ISO A B → FiniteSet B -iso-fin {A} {B} fin iso = record { - Q←F = λ f → ISO.B←A iso ( FiniteSet.Q←F fin f ) - ; F←Q = λ b → FiniteSet.F←Q fin ( ISO.A←B iso b ) - ; finiso→ = finiso→ - ; finiso← = finiso← - } where - finiso→ : (q : B) → ISO.B←A iso (FiniteSet.Q←F fin (FiniteSet.F←Q fin (ISO.A←B iso q))) ≡ q - finiso→ q = begin - ISO.B←A iso (FiniteSet.Q←F fin (FiniteSet.F←Q fin (ISO.A←B iso q))) - ≡⟨ cong (λ k → ISO.B←A iso k ) (FiniteSet.finiso→ fin _ ) ⟩ - ISO.B←A iso (ISO.A←B iso q) - ≡⟨ ISO.iso→ iso _ ⟩ - q - ∎ where - open ≡-Reasoning - finiso← : (f : Fin (FiniteSet.finite fin ))→ FiniteSet.F←Q fin (ISO.A←B iso (ISO.B←A iso (FiniteSet.Q←F fin f))) ≡ f - finiso← f = begin - FiniteSet.F←Q fin (ISO.A←B iso (ISO.B←A iso (FiniteSet.Q←F fin f))) - ≡⟨ cong (λ k → FiniteSet.F←Q fin k ) (ISO.iso← iso _) ⟩ - FiniteSet.F←Q fin (FiniteSet.Q←F fin f) - ≡⟨ FiniteSet.finiso← fin _ ⟩ - f - ∎ where - open ≡-Reasoning - -data One : Set where - one : One - -fin-∨1 : {B : Set} → (fb : FiniteSet B ) → FiniteSet (One ∨ B) -fin-∨1 {B} fb = record { - Q←F = Q←F - ; F←Q = F←Q - ; finiso→ = finiso→ - ; finiso← = finiso← - } where - b = FiniteSet.finite fb - Q←F : Fin (suc b) → One ∨ B - Q←F zero = case1 one - Q←F (suc f) = case2 (FiniteSet.Q←F fb f) - F←Q : One ∨ B → Fin (suc b) - F←Q (case1 one) = zero - F←Q (case2 f ) = suc (FiniteSet.F←Q fb f) - finiso→ : (q : One ∨ B) → Q←F (F←Q q) ≡ q - finiso→ (case1 one) = refl - finiso→ (case2 b) = cong (λ k → case2 k ) (FiniteSet.finiso→ fb b) - finiso← : (q : Fin (suc b)) → F←Q (Q←F q) ≡ q - finiso← zero = refl - finiso← (suc f) = cong ( λ k → suc k ) (FiniteSet.finiso← fb f) - - -fin-∨2 : {B : Set} → ( a : ℕ ) → FiniteSet B → FiniteSet (Fin a ∨ B) -fin-∨2 {B} zero fb = iso-fin fb iso where - iso : ISO B (Fin zero ∨ B) - iso = record { - A←B = A←B - ; B←A = λ b → case2 b - ; iso→ = iso→ - ; iso← = λ _ → refl - } where - A←B : Fin zero ∨ B → B - A←B (case2 x) = x - iso→ : (f : Fin zero ∨ B ) → case2 (A←B f) ≡ f - iso→ (case2 x) = refl -fin-∨2 {B} (suc a) fb = iso-fin (fin-∨1 (fin-∨2 a fb) ) iso - where - iso : ISO (One ∨ (Fin a ∨ B) ) (Fin (suc a) ∨ B) - ISO.A←B iso (case1 zero) = case1 one - ISO.A←B iso (case1 (suc f)) = case2 (case1 f) - ISO.A←B iso (case2 b) = case2 (case2 b) - ISO.B←A iso (case1 one) = case1 zero - ISO.B←A iso (case2 (case1 f)) = case1 (suc f) - ISO.B←A iso (case2 (case2 b)) = case2 b - ISO.iso← iso (case1 one) = refl - ISO.iso← iso (case2 (case1 x)) = refl - ISO.iso← iso (case2 (case2 x)) = refl - ISO.iso→ iso (case1 zero) = refl - ISO.iso→ iso (case1 (suc x)) = refl - ISO.iso→ iso (case2 x) = refl - - -FiniteSet→Fin : {A : Set} → (fin : FiniteSet A ) → ISO (Fin (FiniteSet.finite fin)) A -ISO.A←B (FiniteSet→Fin fin) f = FiniteSet.F←Q fin f -ISO.B←A (FiniteSet→Fin fin) f = FiniteSet.Q←F fin f -ISO.iso← (FiniteSet→Fin fin) = FiniteSet.finiso← fin -ISO.iso→ (FiniteSet→Fin fin) = FiniteSet.finiso→ fin - - -fin-∨ : {A B : Set} → FiniteSet A → FiniteSet B → FiniteSet (A ∨ B) -fin-∨ {A} {B} fa fb = iso-fin (fin-∨2 a fb ) iso2 where - a = FiniteSet.finite fa - ia = FiniteSet→Fin fa - iso2 : ISO (Fin a ∨ B ) (A ∨ B) - ISO.A←B iso2 (case1 x) = case1 ( ISO.A←B ia x ) - ISO.A←B iso2 (case2 x) = case2 x - ISO.B←A iso2 (case1 x) = case1 ( ISO.B←A ia x ) - ISO.B←A iso2 (case2 x) = case2 x - ISO.iso← iso2 (case1 x) = cong ( λ k → case1 k ) (ISO.iso← ia x) - ISO.iso← iso2 (case2 x) = refl - ISO.iso→ iso2 (case1 x) = cong ( λ k → case1 k ) (ISO.iso→ ia x) - ISO.iso→ iso2 (case2 x) = refl - -open import Data.Product - -fin-× : {A B : Set} → FiniteSet A → FiniteSet B → FiniteSet (A × B) -fin-× {A} {B} fa fb with FiniteSet→Fin fa -... | a=f = iso-fin (fin-×-f a ) iso-1 where - a = FiniteSet.finite fa - b = FiniteSet.finite fb - iso-1 : ISO (Fin a × B) ( A × B ) - ISO.A←B iso-1 x = ( FiniteSet.F←Q fa (proj₁ x) , proj₂ x) - ISO.B←A iso-1 x = ( FiniteSet.Q←F fa (proj₁ x) , proj₂ x) - ISO.iso← iso-1 x = lemma where - lemma : (FiniteSet.F←Q fa (FiniteSet.Q←F fa (proj₁ x)) , proj₂ x) ≡ ( proj₁ x , proj₂ x ) - lemma = cong ( λ k → ( k , proj₂ x ) ) (FiniteSet.finiso← fa _ ) - ISO.iso→ iso-1 x = cong ( λ k → ( k , proj₂ x ) ) (FiniteSet.finiso→ fa _ ) - - iso-2 : {a : ℕ } → ISO (B ∨ (Fin a × B)) (Fin (suc a) × B) - ISO.A←B iso-2 (zero , b ) = case1 b - ISO.A←B iso-2 (suc fst , b ) = case2 ( fst , b ) - ISO.B←A iso-2 (case1 b) = ( zero , b ) - ISO.B←A iso-2 (case2 (a , b )) = ( suc a , b ) - ISO.iso← iso-2 (case1 x) = refl - ISO.iso← iso-2 (case2 x) = refl - ISO.iso→ iso-2 (zero , b ) = refl - ISO.iso→ iso-2 (suc a , b ) = refl - - fin-×-f : ( a : ℕ ) → FiniteSet ((Fin a) × B) - fin-×-f zero = record { Q←F = λ () ; F←Q = λ () ; finiso→ = λ () ; finiso← = λ () ; finite = 0 } - fin-×-f (suc a) = iso-fin ( fin-∨ fb ( fin-×-f a ) ) iso-2 - -open _∧_ - -fin-∧ : {A B : Set} → FiniteSet A → FiniteSet B → FiniteSet (A ∧ B) -fin-∧ {A} {B} fa fb with FiniteSet→Fin fa -- same thing for our tool -... | a=f = iso-fin (fin-×-f a ) iso-1 where - a = FiniteSet.finite fa - b = FiniteSet.finite fb - iso-1 : ISO (Fin a ∧ B) ( A ∧ B ) - ISO.A←B iso-1 x = record { proj1 = FiniteSet.F←Q fa (proj1 x) ; proj2 = proj2 x} - ISO.B←A iso-1 x = record { proj1 = FiniteSet.Q←F fa (proj1 x) ; proj2 = proj2 x} - ISO.iso← iso-1 x = lemma where - lemma : record { proj1 = FiniteSet.F←Q fa (FiniteSet.Q←F fa (proj1 x)) ; proj2 = proj2 x} ≡ record {proj1 = proj1 x ; proj2 = proj2 x } - lemma = cong ( λ k → record {proj1 = k ; proj2 = proj2 x } ) (FiniteSet.finiso← fa _ ) - ISO.iso→ iso-1 x = cong ( λ k → record {proj1 = k ; proj2 = proj2 x } ) (FiniteSet.finiso→ fa _ ) - - iso-2 : {a : ℕ } → ISO (B ∨ (Fin a ∧ B)) (Fin (suc a) ∧ B) - ISO.A←B iso-2 (record { proj1 = zero ; proj2 = b }) = case1 b - ISO.A←B iso-2 (record { proj1 = suc fst ; proj2 = b }) = case2 ( record { proj1 = fst ; proj2 = b } ) - ISO.B←A iso-2 (case1 b) = record {proj1 = zero ; proj2 = b } - ISO.B←A iso-2 (case2 (record { proj1 = a ; proj2 = b })) = record { proj1 = suc a ; proj2 = b } - ISO.iso← iso-2 (case1 x) = refl - ISO.iso← iso-2 (case2 x) = refl - ISO.iso→ iso-2 (record { proj1 = zero ; proj2 = b }) = refl - ISO.iso→ iso-2 (record { proj1 = suc a ; proj2 = b }) = refl - - fin-×-f : ( a : ℕ ) → FiniteSet ((Fin a) ∧ B) - fin-×-f zero = record { Q←F = λ () ; F←Q = λ () ; finiso→ = λ () ; finiso← = λ () ; finite = 0 } - fin-×-f (suc a) = iso-fin ( fin-∨ fb ( fin-×-f a ) ) iso-2 - --- import Data.Nat.DivMod - -open import Data.Vec -import Data.Product - -exp2 : (n : ℕ ) → exp 2 (suc n) ≡ exp 2 n Data.Nat.+ exp 2 n -exp2 n = begin - exp 2 (suc n) - ≡⟨⟩ - 2 * ( exp 2 n ) - ≡⟨ *-comm 2 (exp 2 n) ⟩ - ( exp 2 n ) * 2 - ≡⟨ *-suc ( exp 2 n ) 1 ⟩ - (exp 2 n ) Data.Nat.+ ( exp 2 n ) * 1 - ≡⟨ cong ( λ k → (exp 2 n ) Data.Nat.+ k ) (proj₂ *-identity (exp 2 n) ) ⟩ - exp 2 n Data.Nat.+ exp 2 n - ∎ where - open ≡-Reasoning - open Data.Product - -cast-iso : {n m : ℕ } → (eq : n ≡ m ) → (f : Fin m ) → cast eq ( cast (sym eq ) f) ≡ f -cast-iso refl zero = refl -cast-iso refl (suc f) = cong ( λ k → suc k ) ( cast-iso refl f ) - - -fin2List : {n : ℕ } → FiniteSet (Vec Bool n) -fin2List {zero} = record { - Q←F = λ _ → Vec.[] - ; F←Q = λ _ → # 0 - ; finiso→ = finiso→ - ; finiso← = finiso← - } where - Q = Vec Bool zero - finiso→ : (q : Q) → [] ≡ q - finiso→ [] = refl - finiso← : (f : Fin (exp 2 zero)) → # 0 ≡ f - finiso← zero = refl -fin2List {suc n} = subst (λ k → FiniteSet (Vec Bool (suc n)) ) (sym (exp2 n)) ( iso-fin (fin-∨ (fin2List ) (fin2List )) iso ) - where - QtoR : Vec Bool (suc n) → Vec Bool n ∨ Vec Bool n - QtoR ( true ∷ x ) = case1 x - QtoR ( false ∷ x ) = case2 x - RtoQ : Vec Bool n ∨ Vec Bool n → Vec Bool (suc n) - RtoQ ( case1 x ) = true ∷ x - RtoQ ( case2 x ) = false ∷ x - isoRQ : (x : Vec Bool (suc n) ) → RtoQ ( QtoR x ) ≡ x - isoRQ (true ∷ _ ) = refl - isoRQ (false ∷ _ ) = refl - isoQR : (x : Vec Bool n ∨ Vec Bool n ) → QtoR ( RtoQ x ) ≡ x - isoQR (case1 x) = refl - isoQR (case2 x) = refl - iso : ISO (Vec Bool n ∨ Vec Bool n) (Vec Bool (suc n)) - iso = record { A←B = QtoR ; B←A = RtoQ ; iso← = isoQR ; iso→ = isoRQ } - -F2L : {Q : Set } {n : ℕ } → (fin : FiniteSet Q ) → n < suc (FiniteSet.finite fin) → ( (q : Q) → toℕ (FiniteSet.F←Q fin q ) < n → Bool ) → Vec Bool n -F2L {Q} {zero} fin _ Q→B = [] -F2L {Q} {suc n} fin (s≤s n<m) Q→B = Q→B (FiniteSet.Q←F fin (fromℕ< n<m)) lemma6 ∷ F2L {Q} fin (NatP.<-trans n<m a<sa ) qb1 where - lemma6 : toℕ (FiniteSet.F←Q fin (FiniteSet.Q←F fin (fromℕ< n<m))) < suc n - lemma6 = subst (λ k → toℕ k < suc n ) (sym (FiniteSet.finiso← fin _ )) (subst (λ k → k < suc n) (sym (toℕ-fromℕ< n<m )) a<sa ) - qb1 : (q : Q) → toℕ (FiniteSet.F←Q fin q) < n → Bool - qb1 q q<n = Q→B q (NatP.<-trans q<n a<sa) - -List2Func : { Q : Set } → {n : ℕ } → (fin : FiniteSet Q ) → n < suc (FiniteSet.finite fin) → Vec Bool n → Q → Bool -List2Func {Q} {zero} fin (s≤s z≤n) [] q = false -List2Func {Q} {suc n} fin (s≤s n<m) (h ∷ t) q with FiniteSet.F←Q fin q ≟ fromℕ< n<m -... | yes _ = h -... | no _ = List2Func {Q} fin (NatP.<-trans n<m a<sa ) t q - -open import Level renaming ( suc to Suc ; zero to Zero) -open import Axiom.Extensionality.Propositional -postulate f-extensionality : { n : Level} → Axiom.Extensionality.Propositional.Extensionality n n - -F2L-iso : { Q : Set } → (fin : FiniteSet Q ) → (x : Vec Bool (FiniteSet.finite fin) ) → F2L fin a<sa (λ q _ → List2Func fin a<sa x q ) ≡ x -F2L-iso {Q} fin x = f2l m a<sa x where - m = FiniteSet.finite fin - f2l : (n : ℕ ) → (n<m : n < suc m )→ (x : Vec Bool n ) → F2L fin n<m (λ q q<n → List2Func fin n<m x q ) ≡ x - f2l zero (s≤s z≤n) [] = refl - f2l (suc n) (s≤s n<m) (h ∷ t ) = lemma1 lemma2 lemma3f where - lemma1 : {n : ℕ } → {h h1 : Bool } → {t t1 : Vec Bool n } → h ≡ h1 → t ≡ t1 → h ∷ t ≡ h1 ∷ t1 - lemma1 refl refl = refl - lemma2 : List2Func fin (s≤s n<m) (h ∷ t) (FiniteSet.Q←F fin (fromℕ< n<m)) ≡ h - lemma2 with FiniteSet.F←Q fin (FiniteSet.Q←F fin (fromℕ< n<m)) ≟ fromℕ< n<m - lemma2 | yes p = refl - lemma2 | no ¬p = ⊥-elim ( ¬p (FiniteSet.finiso← fin _) ) - lemma4 : (q : Q ) → toℕ (FiniteSet.F←Q fin q ) < n → List2Func fin (s≤s n<m) (h ∷ t) q ≡ List2Func fin (NatP.<-trans n<m a<sa) t q - lemma4 q _ with FiniteSet.F←Q fin q ≟ fromℕ< n<m - lemma4 q lt | yes p = ⊥-elim ( nat-≡< (toℕ-fromℕ< n<m) (lemma5 n lt (cong (λ k → toℕ k) p))) where - lemma5 : {j k : ℕ } → ( n : ℕ) → suc j ≤ n → j ≡ k → k < n - lemma5 {zero} (suc n) (s≤s z≤n) refl = s≤s z≤n - lemma5 {suc j} (suc n) (s≤s lt) refl = s≤s (lemma5 {j} n lt refl) - lemma4 q _ | no ¬p = refl - lemma3f : F2L fin (NatP.<-trans n<m a<sa) (λ q q<n → List2Func fin (s≤s n<m) (h ∷ t) q ) ≡ t - lemma3f = begin - F2L fin (NatP.<-trans n<m a<sa) (λ q q<n → List2Func fin (s≤s n<m) (h ∷ t) q ) - ≡⟨ cong (λ k → F2L fin (NatP.<-trans n<m a<sa) ( λ q q<n → k q q<n )) - (f-extensionality ( λ q → - (f-extensionality ( λ q<n → lemma4 q q<n )))) ⟩ - F2L fin (NatP.<-trans n<m a<sa) (λ q q<n → List2Func fin (NatP.<-trans n<m a<sa) t q ) - ≡⟨ f2l n (NatP.<-trans n<m a<sa ) t ⟩ - t - ∎ where - open ≡-Reasoning - - -L2F : {Q : Set } {n : ℕ } → (fin : FiniteSet Q ) → n < suc (FiniteSet.finite fin) → Vec Bool n → (q : Q ) → toℕ (FiniteSet.F←Q fin q ) < n → Bool -L2F fin n<m x q q<n = List2Func fin n<m x q - -L2F-iso : { Q : Set } → (fin : FiniteSet Q ) → (f : Q → Bool ) → (q : Q ) → (L2F fin a<sa (F2L fin a<sa (λ q _ → f q) )) q (toℕ<n _) ≡ f q -L2F-iso {Q} fin f q = l2f m a<sa (toℕ<n _) where - m = FiniteSet.finite fin - lemma11f : {n : ℕ } → (n<m : n < m ) → ¬ ( FiniteSet.F←Q fin q ≡ fromℕ< n<m ) → toℕ (FiniteSet.F←Q fin q) ≤ n → toℕ (FiniteSet.F←Q fin q) < n - lemma11f n<m ¬q=n q≤n = lemma13 n<m (contra-position (lemma12 n<m _) ¬q=n ) q≤n where - lemma13 : {n nq : ℕ } → (n<m : n < m ) → ¬ ( nq ≡ n ) → nq ≤ n → nq < n - lemma13 {0} {0} (s≤s z≤n) nt z≤n = ⊥-elim ( nt refl ) - lemma13 {suc _} {0} (s≤s (s≤s n<m)) nt z≤n = s≤s z≤n - lemma13 {suc n} {suc nq} n<m nt (s≤s nq≤n) = s≤s (lemma13 {n} {nq} (NatP.<-trans a<sa n<m ) (λ eq → nt ( cong ( λ k → suc k ) eq )) nq≤n) - lemma3f : {a b : ℕ } → (lt : a < b ) → fromℕ< (s≤s lt) ≡ suc (fromℕ< lt) - lemma3f (s≤s lt) = refl - lemma12f : {n m : ℕ } → (n<m : n < m ) → (f : Fin m ) → toℕ f ≡ n → f ≡ fromℕ< n<m - lemma12f {zero} {suc m} (s≤s z≤n) zero refl = refl - lemma12f {suc n} {suc m} (s≤s n<m) (suc f) refl = subst ( λ k → suc f ≡ k ) (sym (lemma3f n<m) ) ( cong ( λ k → suc k ) ( lemma12f {n} {m} n<m f refl ) ) - l2f : (n : ℕ ) → (n<m : n < suc m ) → (q<n : toℕ (FiniteSet.F←Q fin q ) < n ) → (L2F fin n<m (F2L fin n<m (λ q _ → f q))) q q<n ≡ f q - l2f zero (s≤s z≤n) () - l2f (suc n) (s≤s n<m) (s≤s n<q) with FiniteSet.F←Q fin q ≟ fromℕ< n<m - l2f (suc n) (s≤s n<m) (s≤s n<q) | yes p = begin - f (FiniteSet.Q←F fin (fromℕ< n<m)) - ≡⟨ cong ( λ k → f (FiniteSet.Q←F fin k )) (sym p) ⟩ - f (FiniteSet.Q←F fin ( FiniteSet.F←Q fin q )) - ≡⟨ cong ( λ k → f k ) (FiniteSet.finiso→ fin _ ) ⟩ - f q - ∎ where - open ≡-Reasoning - l2f (suc n) (s≤s n<m) (s≤s n<q) | no ¬p = l2f n (NatP.<-trans n<m a<sa) (lemma11f n<m ¬p n<q) - -fin→ : {A : Set} → FiniteSet A → FiniteSet (A → Bool ) -fin→ {A} fin = iso-fin fin2List iso where - a = FiniteSet.finite fin - iso : ISO (Vec Bool a ) (A → Bool) - ISO.A←B iso x = F2L fin a<sa ( λ q _ → x q ) - ISO.B←A iso x = List2Func fin a<sa x - ISO.iso← iso x = F2L-iso fin x - ISO.iso→ iso x = lemma where - lemma : List2Func fin a<sa (F2L fin a<sa (λ q _ → x q)) ≡ x - lemma = f-extensionality ( λ q → L2F-iso fin x q ) - - -Fin2Finite : ( n : ℕ ) → FiniteSet (Fin n) -Fin2Finite n = record { F←Q = λ x → x ; Q←F = λ x → x ; finiso← = λ q → refl ; finiso→ = λ q → refl } - -data fin-less { n : ℕ } { A : Set } (fa : FiniteSet A ) (n<m : n < FiniteSet.finite fa ) : Set where - elm1 : (elm : A ) → toℕ (FiniteSet.F←Q fa elm ) < n → fin-less fa n<m - -get-elm : { n : ℕ } { A : Set } {fa : FiniteSet A } {n<m : n < FiniteSet.finite fa } → fin-less fa n<m → A -get-elm (elm1 a _ ) = a - -get-< : { n : ℕ } { A : Set } {fa : FiniteSet A } {n<m : n < FiniteSet.finite fa }→ (f : fin-less fa n<m ) → toℕ (FiniteSet.F←Q fa (get-elm f )) < n -get-< (elm1 _ b ) = b - -fin-less-cong : { n : ℕ } { A : Set } (fa : FiniteSet A ) (n<m : n < FiniteSet.finite fa ) - → (x y : fin-less fa n<m ) → get-elm {n} {A} {fa} x ≡ get-elm {n} {A} {fa} y → get-< x ≅ get-< y → x ≡ y -fin-less-cong fa n<m (elm1 elm x) (elm1 elm x) refl HE.refl = refl - -fin-< : {A : Set} → { n : ℕ } → (fa : FiniteSet A ) → (n<m : n < FiniteSet.finite fa ) → FiniteSet (fin-less fa n<m ) -fin-< {A} {n} fa n<m = iso-fin (Fin2Finite n) iso where - m = FiniteSet.finite fa - iso : ISO (Fin n) (fin-less fa n<m ) - lemma8f : {i j n : ℕ } → ( i ≡ j ) → {i<n : i < n } → {j<n : j < n } → i<n ≅ j<n - lemma8f {zero} {zero} {suc n} refl {s≤s z≤n} {s≤s z≤n} = HE.refl - lemma8f {suc i} {suc i} {suc n} refl {s≤s i<n} {s≤s j<n} = HE.cong (λ k → s≤s k ) ( lemma8f {i} {i} refl ) - lemma10f : {n i j : ℕ } → ( i ≡ j ) → {i<n : i < n } → {j<n : j < n } → fromℕ< i<n ≡ fromℕ< j<n - lemma10f refl = HE.≅-to-≡ (HE.cong (λ k → fromℕ< k ) (lemma8f refl )) - lemma3f : {a b c : ℕ } → { a<b : a < b } { b<c : b < c } { a<c : a < c } → NatP.<-trans a<b b<c ≡ a<c - lemma3f {a} {b} {c} {a<b} {b<c} {a<c} = HE.≅-to-≡ (lemma8f refl) - lemma11f : {n : ℕ } {x : Fin n } → (n<m : n < m ) → toℕ (fromℕ< (NatP.<-trans (toℕ<n x) n<m)) ≡ toℕ x - lemma11f {n} {x} n<m = begin - toℕ (fromℕ< (NatP.<-trans (toℕ<n x) n<m)) - ≡⟨ toℕ-fromℕ< _ ⟩ - toℕ x - ∎ where - open ≡-Reasoning - ISO.A←B iso (elm1 elm x) = fromℕ< x - ISO.B←A iso x = elm1 (FiniteSet.Q←F fa (fromℕ< (NatP.<-trans x<n n<m ))) to<n where - x<n : toℕ x < n - x<n = toℕ<n x - to<n : toℕ (FiniteSet.F←Q fa (FiniteSet.Q←F fa (fromℕ< (NatP.<-trans x<n n<m)))) < n - to<n = subst (λ k → toℕ k < n ) (sym (FiniteSet.finiso← fa _ )) (subst (λ k → k < n ) (sym ( toℕ-fromℕ< (NatP.<-trans x<n n<m) )) x<n ) - ISO.iso← iso x = lemma2 where - lemma2 : fromℕ< (subst (λ k → toℕ k < n) (sym - (FiniteSet.finiso← fa (fromℕ< (NatP.<-trans (toℕ<n x) n<m)))) (subst (λ k → k < n) - (sym (toℕ-fromℕ< (NatP.<-trans (toℕ<n x) n<m))) (toℕ<n x))) ≡ x - lemma2 = begin - fromℕ< (subst (λ k → toℕ k < n) (sym - (FiniteSet.finiso← fa (fromℕ< (NatP.<-trans (toℕ<n x) n<m)))) (subst (λ k → k < n) - (sym (toℕ-fromℕ< (NatP.<-trans (toℕ<n x) n<m))) (toℕ<n x))) - ≡⟨⟩ - fromℕ< ( subst (λ k → toℕ ( k ) < n ) (sym (FiniteSet.finiso← fa _ )) lemma6 ) - ≡⟨ lemma10 (cong (λ k → toℕ k) (FiniteSet.finiso← fa _ ) ) ⟩ - fromℕ< lemma6 - ≡⟨ lemma10 (lemma11 n<m ) ⟩ - fromℕ< ( toℕ<n x ) - ≡⟨ fromℕ<-toℕ _ _ ⟩ - x - ∎ where - open ≡-Reasoning - lemma6 : toℕ (fromℕ< (NatP.<-trans (toℕ<n x) n<m)) < n - lemma6 = subst ( λ k → k < n ) (sym (toℕ-fromℕ< (NatP.<-trans (toℕ<n x) n<m))) (toℕ<n x ) - ISO.iso→ iso (elm1 elm x) = fin-less-cong fa n<m _ _ lemma (lemma8 (cong (λ k → toℕ (FiniteSet.F←Q fa k) ) lemma ) ) where - lemma13 : toℕ (fromℕ< x) ≡ toℕ (FiniteSet.F←Q fa elm) - lemma13 = begin - toℕ (fromℕ< x) - ≡⟨ toℕ-fromℕ< _ ⟩ - toℕ (FiniteSet.F←Q fa elm) - ∎ where open ≡-Reasoning - lemma : FiniteSet.Q←F fa (fromℕ< (NatP.<-trans (toℕ<n (ISO.A←B iso (elm1 elm x))) n<m)) ≡ elm - lemma = begin - FiniteSet.Q←F fa (fromℕ< (NatP.<-trans (toℕ<n (ISO.A←B iso (elm1 elm x))) n<m)) - ≡⟨⟩ - FiniteSet.Q←F fa (fromℕ< ( NatP.<-trans (toℕ<n ( fromℕ< x ) ) n<m)) - ≡⟨ cong (λ k → FiniteSet.Q←F fa k) (lemma10 lemma13 ) ⟩ - FiniteSet.Q←F fa (fromℕ< ( NatP.<-trans x n<m)) - ≡⟨ cong (λ k → FiniteSet.Q←F fa (fromℕ< k )) {!!} ⟩ - FiniteSet.Q←F fa (fromℕ< ( toℕ<n (FiniteSet.F←Q fa elm))) - ≡⟨ cong (λ k → FiniteSet.Q←F fa k ) ( fromℕ<-toℕ _ _ ) ⟩ - FiniteSet.Q←F fa (FiniteSet.F←Q fa elm ) - ≡⟨ FiniteSet.finiso→ fa _ ⟩ - elm - ∎ where open ≡-Reasoning - -
--- a/automaton-in-agda/src/agda/flcagl.agda Sun Jun 13 18:48:57 2021 +0900 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,481 +0,0 @@ -open import Relation.Nullary -open import Relation.Binary.PropositionalEquality -module flcagl - (A : Set) - ( _≟_ : (a b : A) → Dec ( a ≡ b ) ) where - -open import Data.Bool hiding ( _≟_ ) --- open import Data.Maybe -open import Level renaming ( zero to Zero ; suc to succ ) -open import Size - -module List where - - data List (i : Size) (A : Set) : Set where - [] : List i A - _∷_ : {j : Size< i} (x : A) (xs : List j A) → List i A - - - map : ∀{i A B} → (A → B) → List i A → List i B - map f [] = [] - map f ( x ∷ xs)= f x ∷ map f xs - - foldr : ∀{i} {A B : Set} → (A → B → B) → B → List i A → B - foldr c n [] = n - foldr c n (x ∷ xs) = c x (foldr c n xs) - - any : ∀{i A} → (A → Bool) → List i A → Bool - any p xs = foldr _∨_ false (map p xs) - -module Lang where - - open List - - record Lang (i : Size) : Set where - coinductive - field - ν : Bool - δ : ∀{j : Size< i} → A → Lang j - - open Lang - - _∋_ : ∀{i} → Lang i → List i A → Bool - l ∋ [] = ν l - l ∋ ( a ∷ as ) = δ l a ∋ as - - trie : ∀{i} (f : List i A → Bool) → Lang i - ν (trie f) = f [] - δ (trie f) a = trie (λ as → f (a ∷ as)) - - ∅ : ∀{i} → Lang i - ν ∅ = false - δ ∅ x = ∅ - - ε : ∀{i} → Lang i - ν ε = true - δ ε x = ∅ - - open import Relation.Nullary.Decidable - - char : ∀{i} (a : A) → Lang i - ν (char a) = false - δ (char a) x = if ⌊ a ≟ x ⌋ then ε else ∅ - - compl : ∀{i} (l : Lang i) → Lang i - ν (compl l) = not (ν l) - δ (compl l) x = compl (δ l x) - - - _∪_ : ∀{i} (k l : Lang i) → Lang i - ν (k ∪ l) = ν k ∨ ν l - δ (k ∪ l) x = δ k x ∪ δ l x - - - _·_ : ∀{i} (k l : Lang i) → Lang i - ν (k · l) = ν k ∧ ν l - δ (k · l) x = let k′l = δ k x · l in if ν k then k′l ∪ δ l x else k′l - - _*_ : ∀{i} (k l : Lang i ) → Lang i - ν (k * l) = ν k ∧ ν l - δ (_*_ {i} k l) {j} x = - let - k′l : Lang j - k′l = _*_ {j} (δ k {j} x) l - in if ν k then _∪_ {j} k′l (δ l {j} x) else k′l - - _* : ∀{i} (l : Lang i) → Lang i - ν (l *) = true - δ (l *) x = δ l x · (l *) - - record _≅⟨_⟩≅_ (l : Lang ∞ ) i (k : Lang ∞) : Set where - coinductive - field ≅ν : ν l ≡ ν k - ≅δ : ∀ {j : Size< i } (a : A ) → δ l a ≅⟨ j ⟩≅ δ k a - - open _≅⟨_⟩≅_ - - ≅refl : ∀{i} {l : Lang ∞} → l ≅⟨ i ⟩≅ l - ≅ν ≅refl = refl - ≅δ ≅refl a = ≅refl - - - ≅sym : ∀{i} {k l : Lang ∞} (p : l ≅⟨ i ⟩≅ k) → k ≅⟨ i ⟩≅ l - ≅ν (≅sym p) = sym (≅ν p) - ≅δ (≅sym p) a = ≅sym (≅δ p a) - - ≅trans : ∀{i} {k l m : Lang ∞} - ( p : k ≅⟨ i ⟩≅ l ) ( q : l ≅⟨ i ⟩≅ m ) → k ≅⟨ i ⟩≅ m - ≅ν (≅trans p q) = trans (≅ν p) (≅ν q) - ≅δ (≅trans p q) a = ≅trans (≅δ p a) (≅δ q a) - - open import Relation.Binary - - ≅isEquivalence : ∀(i : Size) → IsEquivalence _≅⟨ i ⟩≅_ - ≅isEquivalence i = record { refl = ≅refl; sym = ≅sym; trans = ≅trans } - - Bis : ∀(i : Size) → Setoid _ _ - Setoid.Carrier (Bis i) = Lang ∞ - Setoid._≈_ (Bis i) = _≅⟨ i ⟩≅_ - Setoid.isEquivalence (Bis i) = ≅isEquivalence i - - import Relation.Binary.EqReasoning as EqR - - ≅trans′ : ∀ i (k l m : Lang ∞) - ( p : k ≅⟨ i ⟩≅ l ) ( q : l ≅⟨ i ⟩≅ m ) → k ≅⟨ i ⟩≅ m - ≅trans′ i k l m p q = begin - k ≈⟨ p ⟩ - l ≈⟨ q ⟩ - m ∎ where open EqR (Bis i) - - open import Data.Bool.Properties - - union-assoc : ∀{i} (k {l m} : Lang ∞) → ((k ∪ l) ∪ m ) ≅⟨ i ⟩≅ ( k ∪ (l ∪ m) ) - ≅ν (union-assoc k) = ∨-assoc (ν k) _ _ - ≅δ (union-assoc k) a = union-assoc (δ k a) - union-comm : ∀{i} (l k : Lang ∞) → (l ∪ k ) ≅⟨ i ⟩≅ ( k ∪ l ) - ≅ν (union-comm l k) = ∨-comm (ν l) _ - ≅δ (union-comm l k) a = union-comm (δ l a) (δ k a) - union-idem : ∀{i} (l : Lang ∞) → (l ∪ l ) ≅⟨ i ⟩≅ l - ≅ν (union-idem l) = ∨-idem _ - ≅δ (union-idem l) a = union-idem (δ l a) - union-emptyl : ∀{i}{l : Lang ∞} → (∅ ∪ l ) ≅⟨ i ⟩≅ l - ≅ν union-emptyl = refl - ≅δ union-emptyl a = union-emptyl - - union-cong : ∀{i}{k k′ l l′ : Lang ∞} - (p : k ≅⟨ i ⟩≅ k′) (q : l ≅⟨ i ⟩≅ l′ ) → ( k ∪ l ) ≅⟨ i ⟩≅ ( k′ ∪ l′ ) - ≅ν (union-cong p q) = cong₂ _∨_ (≅ν p) (≅ν q) - ≅δ (union-cong p q) a = union-cong (≅δ p a) (≅δ q a) - - withExample : (P : Bool → Set) (p : P true) (q : P false) → - {A : Set} (g : A → Bool) (x : A) → P (g x) - withExample P p q g x with g x - ... | true = p - ... | false = q - - rewriteExample : {A : Set} {P : A → Set} {x : A} (p : P x) - {g : A → A} (e : g x ≡ x) → P (g x) - rewriteExample p e rewrite e = p - - infixr 6 _∪_ - infixr 7 _·_ - infix 5 _≅⟨_⟩≅_ - - union-congl : ∀{i}{k k′ l : Lang ∞} - (p : k ≅⟨ i ⟩≅ k′) → ( k ∪ l ) ≅⟨ i ⟩≅ ( k′ ∪ l ) - union-congl eq = union-cong eq ≅refl - - union-congr : ∀{i}{k l l′ : Lang ∞} - (p : l ≅⟨ i ⟩≅ l′) → ( k ∪ l ) ≅⟨ i ⟩≅ ( k ∪ l′ ) - union-congr eq = union-cong ≅refl eq - - union-swap24 : ∀{i} ({x y z w} : Lang ∞) → (x ∪ y) ∪ z ∪ w - ≅⟨ i ⟩≅ (x ∪ z) ∪ y ∪ w - union-swap24 {_} {x} {y} {z} {w} = begin - (x ∪ y) ∪ z ∪ w - ≈⟨ union-assoc x ⟩ - x ∪ y ∪ z ∪ w - ≈⟨ union-congr (≅sym ( union-assoc y)) ⟩ - x ∪ ((y ∪ z) ∪ w) - ≈⟨ ≅sym ( union-assoc x ) ⟩ - (x ∪ ( y ∪ z)) ∪ w - ≈⟨ union-congl (union-congr (union-comm y z )) ⟩ - ( x ∪ (z ∪ y)) ∪ w - ≈⟨ union-congl (≅sym ( union-assoc x )) ⟩ - ((x ∪ z) ∪ y) ∪ w - ≈⟨ union-assoc (x ∪ z) ⟩ - (x ∪ z) ∪ y ∪ w - ∎ - where open EqR (Bis _) - - concat-union-distribr : ∀{i} (k {l m} : Lang ∞) → k · ( l ∪ m ) ≅⟨ i ⟩≅ ( k · l ) ∪ ( k · m ) - ≅ν (concat-union-distribr k) = ∧-distribˡ-∨ (ν k) _ _ - ≅δ (concat-union-distribr k) a with ν k - ≅δ (concat-union-distribr k {l} {m}) a | true = begin - δ k a · (l ∪ m) ∪ (δ l a ∪ δ m a) - ≈⟨ union-congl (concat-union-distribr _) ⟩ - (δ k a · l ∪ δ k a · m) ∪ (δ l a ∪ δ m a) - ≈⟨ union-swap24 ⟩ - (δ k a · l ∪ δ l a) ∪ (δ k a · m ∪ δ m a) - ∎ - where open EqR (Bis _) - ≅δ (concat-union-distribr k) a | false = concat-union-distribr (δ k a) - - concat-union-distribl : ∀{i} (k {l m} : Lang ∞) → ( k ∪ l ) · m ≅⟨ i ⟩≅ ( k · m ) ∪ ( l · m ) - ≅ν (concat-union-distribl k {l} {m}) = ∧-distribʳ-∨ _ (ν k) _ - ≅δ (concat-union-distribl k {l} {m}) a with ν k | ν l - ≅δ (concat-union-distribl k {l} {m}) a | false | false = concat-union-distribl (δ k a) - ≅δ (concat-union-distribl k {l} {m}) a | false | true = begin - (if false ∨ true then (δ k a ∪ δ l a) · m ∪ δ m a else (δ k a ∪ δ l a) · m) - ≈⟨ ≅refl ⟩ - ((δ k a ∪ δ l a) · m ) ∪ δ m a - ≈⟨ union-congl (concat-union-distribl _) ⟩ - (δ k a · m ∪ δ l a · m) ∪ δ m a - ≈⟨ union-assoc _ ⟩ - (δ k a · m) ∪ ( δ l a · m ∪ δ m a ) - ≈⟨ ≅refl ⟩ - (if false then δ k a · m ∪ δ m a else δ k a · m) ∪ (if true then δ l a · m ∪ δ m a else δ l a · m) - ∎ - where open EqR (Bis _) - ≅δ (concat-union-distribl k {l} {m}) a | true | false = begin - (if true ∨ false then (δ k a ∪ δ l a) · m ∪ δ m a else (δ k a ∪ δ l a) · m) ≈⟨ ≅refl ⟩ - ((δ k a ∪ δ l a) · m ) ∪ δ m a ≈⟨ union-congl (concat-union-distribl _) ⟩ - (δ k a · m ∪ δ l a · m) ∪ δ m a ≈⟨ union-assoc _ ⟩ - δ k a · m ∪ ( δ l a · m ∪ δ m a ) ≈⟨ union-congr ( union-comm _ _) ⟩ - δ k a · m ∪ δ m a ∪ δ l a · m ≈⟨ ≅sym ( union-assoc _ ) ⟩ - (δ k a · m ∪ δ m a) ∪ δ l a · m ≈⟨ ≅refl ⟩ - ((if true then δ k a · m ∪ δ m a else δ k a · m) ∪ (if false then δ l a · m ∪ δ m a else δ l a · m)) - ∎ - where open EqR (Bis _) - ≅δ (concat-union-distribl k {l} {m}) a | true | true = begin - (if true ∨ true then (δ k a ∪ δ l a) · m ∪ δ m a else (δ k a ∪ δ l a) · m) ≈⟨ ≅refl ⟩ - (δ k a ∪ δ l a) · m ∪ δ m a ≈⟨ union-congl ( concat-union-distribl _ ) ⟩ - (δ k a · m ∪ δ l a · m) ∪ δ m a ≈⟨ union-assoc _ ⟩ - δ k a · m ∪ ( δ l a · m ∪ δ m a ) ≈⟨ ≅sym ( union-congr ( union-congr ( union-idem _ ) ) ) ⟩ - δ k a · m ∪ ( δ l a · m ∪ (δ m a ∪ δ m a) ) ≈⟨ ≅sym ( union-congr ( union-assoc _ )) ⟩ - δ k a · m ∪ ( (δ l a · m ∪ δ m a ) ∪ δ m a ) ≈⟨ union-congr ( union-congl ( union-comm _ _) ) ⟩ - δ k a · m ∪ ( (δ m a ∪ δ l a · m ) ∪ δ m a ) ≈⟨ ≅sym ( union-assoc _ ) ⟩ - ( δ k a · m ∪ (δ m a ∪ δ l a · m )) ∪ δ m a ≈⟨ ≅sym ( union-congl ( union-assoc _ ) ) ⟩ - ((δ k a · m ∪ δ m a) ∪ δ l a · m) ∪ δ m a ≈⟨ union-assoc _ ⟩ - (δ k a · m ∪ δ m a) ∪ δ l a · m ∪ δ m a ≈⟨ ≅refl ⟩ - ((if true then δ k a · m ∪ δ m a else δ k a · m) ∪ (if true then δ l a · m ∪ δ m a else δ l a · m)) - ∎ - where open EqR (Bis _) - - postulate - concat-emptyl : ∀{i} l → ∅ · l ≅⟨ i ⟩≅ ∅ - concat-emptyr : ∀{i} l → l · ∅ ≅⟨ i ⟩≅ ∅ - concat-unitl : ∀{i} l → ε · l ≅⟨ i ⟩≅ l - concat-unitr : ∀{i} l → l · ε ≅⟨ i ⟩≅ l - star-empty : ∀{i} → ∅ * ≅⟨ i ⟩≅ ε - - concat-congl : ∀{i} {m l k : Lang ∞} → l ≅⟨ i ⟩≅ k → l · m ≅⟨ i ⟩≅ k · m - ≅ν (concat-congl {i} {m} p ) = cong (λ x → x ∧ ( ν m )) ( ≅ν p ) - ≅δ (concat-congl {i} {m} {l} {k} p ) a with ν k | ν l | ≅ν p - ≅δ (concat-congl {i} {m} {l} {k} p) a | false | false | refl = concat-congl (≅δ p a) - ≅δ (concat-congl {i} {m} {l} {k} p) a | true | true | refl = union-congl (concat-congl (≅δ p a)) - - concat-congr : ∀{i} {m l k : Lang ∞} → l ≅⟨ i ⟩≅ k → m · l ≅⟨ i ⟩≅ m · k - ≅ν (concat-congr {i} {m} {_} {k} p ) = cong (λ x → ( ν m ) ∧ x ) ( ≅ν p ) - ≅δ (concat-congr {i} {m} {l} {k} p ) a with ν m | ν k | ν l | ≅ν p - ≅δ (concat-congr {i} {m} {l} {k} p) a | false | x | .x | refl = concat-congr p - ≅δ (concat-congr {i} {m} {l} {k} p) a | true | x | .x | refl = union-cong (concat-congr p ) ( ≅δ p a ) - - concat-assoc : ∀{i} (k {l m} : Lang ∞) → (k · l) · m ≅⟨ i ⟩≅ k · (l · m) - ≅ν (concat-assoc {i} k {l} {m} ) = ∧-assoc ( ν k ) ( ν l ) ( ν m ) - ≅δ (concat-assoc {i} k {l} {m} ) a with ν k - ≅δ (concat-assoc {i} k {l} {m}) a | false = concat-assoc _ - ≅δ (concat-assoc {i} k {l} {m}) a | true with ν l - ≅δ (concat-assoc {i} k {l} {m}) a | true | false = begin - ( if false then (δ k a · l ∪ δ l a) · m ∪ δ m a else (δ k a · l ∪ δ l a) · m ) - ≈⟨ ≅refl ⟩ - (δ k a · l ∪ δ l a) · m - ≈⟨ concat-union-distribl _ ⟩ - ((δ k a · l) · m ) ∪ ( δ l a · m ) - ≈⟨ union-congl (concat-assoc _) ⟩ - (δ k a · l · m ) ∪ ( δ l a · m ) - ≈⟨ ≅refl ⟩ - δ k a · l · m ∪ (if false then δ l a · m ∪ δ m a else δ l a · m) - ∎ where open EqR (Bis _) - ≅δ (concat-assoc {i} k {l} {m}) a | true | true = begin - (if true then (δ k a · l ∪ δ l a) · m ∪ δ m a else (δ k a · l ∪ δ l a) · m) - ≈⟨ ≅refl ⟩ - ((( δ k a · l ) ∪ δ l a) · m ) ∪ δ m a - ≈⟨ union-congl (concat-union-distribl _ ) ⟩ - ((δ k a · l) · m ∪ ( δ l a · m )) ∪ δ m a - ≈⟨ union-congl ( union-congl (concat-assoc _)) ⟩ - (( δ k a · l · m ) ∪ ( δ l a · m )) ∪ δ m a - ≈⟨ union-assoc _ ⟩ - ( δ k a · l · m ) ∪ ( ( δ l a · m ) ∪ δ m a ) - ≈⟨ ≅refl ⟩ - δ k a · l · m ∪ (if true then δ l a · m ∪ δ m a else δ l a · m) - ∎ where open EqR (Bis _) - - star-concat-idem : ∀{i} (l : Lang ∞) → l * · l * ≅⟨ i ⟩≅ l * - ≅ν (star-concat-idem l) = refl - ≅δ (star-concat-idem l) a = begin - δ ((l *) · (l *)) a ≈⟨ union-congl (concat-assoc _) ⟩ - δ l a · (l * · l *) ∪ δ l a · l * ≈⟨ union-congl (concat-congr (star-concat-idem _)) ⟩ - δ l a · l * ∪ δ l a · l * ≈⟨ union-idem _ ⟩ - δ (l *) a ∎ where open EqR (Bis _) - - star-idem : ∀{i} (l : Lang ∞) → (l *) * ≅⟨ i ⟩≅ l * - ≅ν (star-idem l) = refl - ≅δ (star-idem l) a = begin - δ ((l *) *) a ≈⟨ concat-assoc (δ l a) ⟩ - δ l a · ((l *) · ((l *) *)) ≈⟨ concat-congr ( concat-congr (star-idem l )) ⟩ - δ l a · ((l *) · (l *)) ≈⟨ concat-congr (star-concat-idem l ) ⟩ - δ l a · l * - ∎ where open EqR (Bis _) - - postulate - star-rec : ∀{i} (l : Lang ∞) → l * ≅⟨ i ⟩≅ ε ∪ (l · l *) - - star-from-rec : ∀{i} (k {l m} : Lang ∞) - → ν k ≡ false - → l ≅⟨ i ⟩≅ k · l ∪ m - → l ≅⟨ i ⟩≅ k * · m - ≅ν (star-from-rec k n p) with ≅ν p - ... | b rewrite n = b - ≅δ (star-from-rec k {l} {m} n p) a with ≅δ p a - ... | q rewrite n = begin - (δ l a) - ≈⟨ q ⟩ - δ k a · l ∪ δ m a - ≈⟨ union-congl (concat-congr (star-from-rec k {l} {m} n p)) ⟩ - (δ k a · (k * · m) ∪ δ m a) - ≈⟨ union-congl (≅sym (concat-assoc _)) ⟩ - (δ k a · (k *)) · m ∪ δ m a - ∎ where open EqR (Bis _) - - -open List - -record DA (S : Set) : Set where - field ν : (s : S) → Bool - δ : (s : S)(a : A) → S - νs : ∀{i} (ss : List.List i S) → Bool - νs ss = List.any ν ss - δs : ∀{i} (ss : List.List i S) (a : A) → List.List i S - δs ss a = List.map (λ s → δ s a) ss - -open Lang - -lang : ∀{i} {S} (da : DA S) (s : S) → Lang i -Lang.ν (lang da s) = DA.ν da s -Lang.δ (lang da s) a = lang da (DA.δ da s a) - -open import Data.Unit hiding ( _≟_ ) - -open DA - -∅A : DA ⊤ -ν ∅A s = false -δ ∅A s a = s - -εA : DA Bool -ν εA b = b -δ εA b a = false - -open import Relation.Nullary.Decidable - -data 3States : Set where - init acc err : 3States - -charA : (a : A) → DA 3States -ν (charA a) init = false -ν (charA a) acc = true -ν (charA a) err = false -δ (charA a) init x = - if ⌊ a ≟ x ⌋ then acc else err -δ (charA a) acc x = err -δ (charA a) err x = err - - -complA : ∀{S} (da : DA S) → DA S -ν (complA da) s = not (ν da s) -δ (complA da) s a = δ da s a - -open import Data.Product - -_⊕_ : ∀{S1 S2} (da1 : DA S1) (da2 : DA S2) → DA (S1 × S2) -ν (da1 ⊕ da2) (s1 , s2) = ν da1 s1 ∨ ν da2 s2 -δ (da1 ⊕ da2) (s1 , s2) a = δ da1 s1 a , δ da2 s2 a - -powA : ∀{S} (da : DA S) → DA (List ∞ S) -ν (powA da) ss = νs da ss -δ (powA da) ss a = δs da ss a - -open _≅⟨_⟩≅_ - -powA-nil : ∀{i S} (da : DA S) → lang (powA da) [] ≅⟨ i ⟩≅ ∅ -≅ν (powA-nil da) = refl -≅δ (powA-nil da) a = powA-nil da - -powA-cons : ∀{i S} (da : DA S) {s : S} {ss : List ∞ S} → - lang (powA da) (s ∷ ss) ≅⟨ i ⟩≅ lang da s ∪ lang (powA da) ss -≅ν (powA-cons da) = refl -≅δ (powA-cons da) a = powA-cons da - -composeA : ∀{S1 S2} (da1 : DA S1)(s2 : S2)(da2 : DA S2) → DA (S1 × List ∞ S2) -ν (composeA da1 s2 da2) (s1 , ss2) = (ν da1 s1 ∧ ν da2 s2) ∨ νs da2 ss2 -δ (composeA da1 s2 da2) (s1 , ss2) a = - δ da1 s1 a , δs da2 (if ν da1 s1 then s2 ∷ ss2 else ss2) a - -import Relation.Binary.EqReasoning as EqR - -composeA-gen : ∀{i S1 S2} (da1 : DA S1) (da2 : DA S2) → ∀(s1 : S1)(s2 : S2)(ss : List ∞ S2) → - lang (composeA da1 s2 da2) (s1 , ss) ≅⟨ i ⟩≅ lang da1 s1 · lang da2 s2 ∪ lang (powA da2) ss -≅ν (composeA-gen da1 da2 s1 s2 ss) = refl -≅δ (composeA-gen da1 da2 s1 s2 ss) a with ν da1 s1 -... | false = composeA-gen da1 da2 (δ da1 s1 a) s2 (δs da2 ss a) -... | true = begin - lang (composeA da1 s2 da2) (δ da1 s1 a , δ da2 s2 a ∷ δs da2 ss a) - ≈⟨ composeA-gen da1 da2 (δ da1 s1 a) s2 (δs da2 (s2 ∷ ss) a) ⟩ - lang da1 (δ da1 s1 a) · lang da2 s2 ∪ lang (powA da2) (δs da2 (s2 ∷ ss) a) - ≈⟨ union-congr (powA-cons da2) ⟩ - lang da1 (δ da1 s1 a) · lang da2 s2 ∪ - (lang da2 (δ da2 s2 a) ∪ lang (powA da2) (δs da2 ss a)) - ≈⟨ ≅sym (union-assoc _) ⟩ - (lang da1 (δ da1 s1 a) · lang da2 s2 ∪ lang da2 (δ da2 s2 a)) ∪ lang (powA da2) (δs da2 ss a) - ∎ where open EqR (Bis _) - -postulate - composeA-correct : ∀{i S1 S2} (da1 : DA S1) (da2 : DA S2) s1 s2 → - lang (composeA da1 s2 da2) (s1 , []) ≅⟨ i ⟩≅ lang da1 s1 · lang da2 s2 - - -open import Data.Maybe - -acceptingInitial : ∀{S} (s0 : S) (da : DA S) → DA (Maybe S) -ν (acceptingInitial s0 da) (just s) = ν da s -δ (acceptingInitial s0 da) (just s) a = just (δ da s a) -ν (acceptingInitial s0 da) nothing = true -δ (acceptingInitial s0 da) nothing a = just (δ da s0 a) - - - -finalToInitial : ∀{S} (da : DA (Maybe S)) → DA (List ∞ (Maybe S)) -ν (finalToInitial da) ss = νs da ss -δ (finalToInitial da) ss a = - let ss′ = δs da ss a - in if νs da ss then δ da nothing a ∷ ss′ else ss′ - - -starA : ∀{S}(s0 : S)(da : DA S) → DA (List ∞(Maybe S)) -starA s0 da = finalToInitial (acceptingInitial s0 da) - - -postulate - acceptingInitial-just : ∀{i S} (s0 : S) (da : DA S) {s : S} → - lang (acceptingInitial s0 da) (just s) ≅⟨ i ⟩≅ lang da s - acceptingInitial-nothing : ∀{i S} (s0 : S) (da : DA S) → - lang (acceptingInitial s0 da) nothing ≅⟨ i ⟩≅ ε ∪ lang da s0 - starA-lemma : ∀{i S}(da : DA S)(s0 : S)(ss : List ∞ (Maybe S))→ - lang (starA s0 da) ss ≅⟨ i ⟩≅ - lang (powA (acceptingInitial s0 da)) ss · (lang da s0) * - starA-correct : ∀{i S} (da : DA S) (s0 : S) → - lang (starA s0 da) (nothing ∷ []) ≅⟨ i ⟩≅ (lang da s0) * - -record NAutomaton ( Q : Set ) ( Σ : Set ) - : Set where - field - Nδ : Q → Σ → Q → Bool - Nstart : Q → Bool - Nend : Q → Bool - -postulate - exists : { S : Set} → ( S → Bool ) → Bool - -nlang : ∀{i} {S} (nfa : NAutomaton S A ) (s : S → Bool ) → Lang i -Lang.ν (nlang nfa s) = exists ( λ x → (s x ∧ NAutomaton.Nend nfa x )) -Lang.δ (nlang nfa s) a = nlang nfa (λ x → s x ∧ (NAutomaton.Nδ nfa x a) x) - -nlang1 : ∀{i} {S} (nfa : NAutomaton S A ) (s : S → Bool ) → Lang i -Lang.ν (nlang1 nfa s) = NAutomaton.Nend nfa {!!} -Lang.δ (nlang1 nfa s) a = nlang1 nfa (λ x → s x ∧ (NAutomaton.Nδ nfa x a) x) - --- nlang' : ∀{i} {S} (nfa : DA (S → Bool) ) (s : S → Bool ) → Lang i --- Lang.ν (nlang' nfa s) = DA.ν nfa s --- Lang.δ (nlang' nfa s) a = nlang' nfa (DA.δ nfa s a) -
--- a/automaton-in-agda/src/agda/gcd.agda Sun Jun 13 18:48:57 2021 +0900 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,217 +0,0 @@ -{-# OPTIONS --allow-unsolved-metas #-} -module gcd where - -open import Data.Nat -open import Data.Nat.Properties -open import Data.Empty -open import Data.Unit using (⊤ ; tt) -open import Relation.Nullary -open import Relation.Binary.PropositionalEquality -open import Relation.Binary.Definitions -open import nat -open import logic - -record Factor (n m : ℕ ) : Set where - field - factor : ℕ - remain : ℕ - is-factor : factor * n + remain ≡ m - -record Dividable (n m : ℕ ) : Set where - field - factor : ℕ - is-factor : factor * n + 0 ≡ m - -open Factor - -open ≡-Reasoning - -decf : { n k : ℕ } → ( x : Factor k (suc n) ) → Factor k n -decf {n} {k} x with remain x -... | zero = record { factor = factor x ; remain = k ; is-factor = {!!} } -... | suc r = record { factor = factor x ; remain = r ; is-factor = {!!} } - -ifk0 : ( i0 k : ℕ ) → (i0f : Factor k i0 ) → ( i0=0 : remain i0f ≡ 0 ) → factor i0f * k + 0 ≡ i0 -ifk0 i0 k i0f i0=0 = begin - factor i0f * k + 0 ≡⟨ cong (λ m → factor i0f * k + m) (sym i0=0) ⟩ - factor i0f * k + remain i0f ≡⟨ is-factor i0f ⟩ - i0 ∎ - -ifzero : {k : ℕ } → (jf : Factor k zero ) → remain jf ≡ 0 -ifzero = {!!} - -gcd1 : ( i i0 j j0 : ℕ ) → ℕ -gcd1 zero i0 zero j0 with <-cmp i0 j0 -... | tri< a ¬b ¬c = i0 -... | tri≈ ¬a refl ¬c = i0 -... | tri> ¬a ¬b c = j0 -gcd1 zero i0 (suc zero) j0 = 1 -gcd1 zero zero (suc (suc j)) j0 = j0 -gcd1 zero (suc i0) (suc (suc j)) j0 = gcd1 i0 (suc i0) (suc j) (suc (suc j)) -gcd1 (suc zero) i0 zero j0 = 1 -gcd1 (suc (suc i)) i0 zero zero = i0 -gcd1 (suc (suc i)) i0 zero (suc j0) = gcd1 (suc i) (suc (suc i)) j0 (suc j0) -gcd1 (suc i) i0 (suc j) j0 = gcd1 i i0 j j0 - -gcd : ( i j : ℕ ) → ℕ -gcd i j = gcd1 i i j j - -gcd-gt : ( i i0 j j0 k : ℕ ) → (if : Factor k i) (i0f : Factor k i0 ) (jf : Factor k i ) (j0f : Factor k j0) - → remain i0f ≡ 0 → remain j0f ≡ 0 - → (remain if + i ) ≡ i0 → (remain jf + j ) ≡ j0 - → Dividable k ( gcd1 i i0 j j0 ) -gcd-gt zero i0 zero j0 k if i0f jf j0f i0=0 j0=0 ir=i0 jr=j0 with <-cmp i0 j0 -... | tri< a ¬b ¬c = record { factor = factor i0f ; is-factor = ifk0 i0 k i0f i0=0 } -... | tri≈ ¬a refl ¬c = record { factor = factor i0f ; is-factor = ifk0 i0 k i0f i0=0 } -... | tri> ¬a ¬b c = record { factor = factor j0f ; is-factor = ifk0 j0 k j0f j0=0 } -gcd-gt zero i0 (suc zero) j0 k if i0f jf j0f i0=0 j0=0 ir=i0 jr=j0 = {!!} -- can't happen -gcd-gt zero zero (suc (suc j)) j0 k if i0f jf j0f i0=0 j0=0 ir=i0 jr=j0 = record { factor = factor j0f ; is-factor = ifk0 j0 k j0f j0=0 } -gcd-gt zero (suc i0) (suc (suc j)) j0 k if i0f jf j0f i0=0 j0=0 ir=i0 jr=j0 = - gcd-gt i0 (suc i0) (suc j) (suc (suc j)) k (decf i0f) i0f (decf i0f) - record { factor = factor jf ; remain = remain jf ; is-factor = {!!} } i0=0 {!!} {!!} {!!} -gcd-gt (suc zero) i0 zero j0 k if i0f jf j0f i0=0 j0=0 ir=i0 jr=j0 = {!!} -- can't happen -gcd-gt (suc (suc i)) i0 zero zero k if i0f jf j0f i0=0 j0=0 ir=i0 jr=j0 = {!!} -gcd-gt (suc (suc i)) i0 zero (suc j0) k if i0f jf j0f i0=0 j0=0 ir=i0 jr=j0 = - gcd-gt (suc i) (suc (suc i)) j0 (suc j0) k (decf if) {!!} (decf jf) j0f j0=0 {!!} {!!} {!!} -gcd-gt (suc zero) i0 (suc j) j0 k if i0f jf j0f i0=0 j0=0 ir=i0 jr=j0 = - gcd-gt zero i0 j j0 k (decf if) i0f (decf jf) j0f i0=0 j0=0 {!!} {!!} -gcd-gt (suc (suc i)) i0 (suc j) j0 k if i0f jf j0f i0=0 j0=0 ir=i0 jr=j0 = - gcd-gt (suc i) i0 j j0 k (decf if) i0f (decf jf) j0f i0=0 j0=0 {!!} {!!} - --- gcd26 : { n m : ℕ} → n > 1 → m > 1 → n - m > 0 → gcd n m ≡ gcd (n - m) m --- gcd27 : { n m : ℕ} → n > 1 → m > 1 → n - m > 0 → gcd n k ≡ k → k ≤ n - -gcd22 : ( i i0 o o0 : ℕ ) → gcd1 (suc i) i0 (suc o) o0 ≡ gcd1 i i0 o o0 -gcd22 zero i0 zero o0 = refl -gcd22 zero i0 (suc o) o0 = refl -gcd22 (suc i) i0 zero o0 = refl -gcd22 (suc i) i0 (suc o) o0 = refl - -gcd20 : (i : ℕ) → gcd i 0 ≡ i -gcd20 zero = refl -gcd20 (suc i) = gcd201 (suc i) where - gcd201 : (i : ℕ ) → gcd1 i i zero zero ≡ i - gcd201 zero = refl - gcd201 (suc zero) = refl - gcd201 (suc (suc i)) = refl - -gcdmm : (n m : ℕ) → gcd1 n m n m ≡ m -gcdmm zero m with <-cmp m m -... | tri< a ¬b ¬c = refl -... | tri≈ ¬a refl ¬c = refl -... | tri> ¬a ¬b c = refl -gcdmm (suc n) m = subst (λ k → k ≡ m) (sym (gcd22 n m n m )) (gcdmm n m ) - -gcdsym2 : (i j : ℕ) → gcd1 zero i zero j ≡ gcd1 zero j zero i -gcdsym2 i j with <-cmp i j | <-cmp j i -... | tri< a ¬b ¬c | tri< a₁ ¬b₁ ¬c₁ = ⊥-elim (nat-<> a a₁) -... | tri< a ¬b ¬c | tri≈ ¬a b ¬c₁ = ⊥-elim (nat-≡< (sym b) a) -... | tri< a ¬b ¬c | tri> ¬a ¬b₁ c = refl -... | tri≈ ¬a b ¬c | tri< a ¬b ¬c₁ = ⊥-elim (nat-≡< (sym b) a) -... | tri≈ ¬a refl ¬c | tri≈ ¬a₁ refl ¬c₁ = refl -... | tri≈ ¬a b ¬c | tri> ¬a₁ ¬b c = ⊥-elim (nat-≡< b c) -... | tri> ¬a ¬b c | tri< a ¬b₁ ¬c = refl -... | tri> ¬a ¬b c | tri≈ ¬a₁ b ¬c = ⊥-elim (nat-≡< b c) -... | tri> ¬a ¬b c | tri> ¬a₁ ¬b₁ c₁ = ⊥-elim (nat-<> c c₁) -gcdsym1 : ( i i0 j j0 : ℕ ) → gcd1 i i0 j j0 ≡ gcd1 j j0 i i0 -gcdsym1 zero zero zero zero = refl -gcdsym1 zero zero zero (suc j0) = refl -gcdsym1 zero (suc i0) zero zero = refl -gcdsym1 zero (suc i0) zero (suc j0) = gcdsym2 (suc i0) (suc j0) -gcdsym1 zero zero (suc zero) j0 = refl -gcdsym1 zero zero (suc (suc j)) j0 = refl -gcdsym1 zero (suc i0) (suc zero) j0 = refl -gcdsym1 zero (suc i0) (suc (suc j)) j0 = gcdsym1 i0 (suc i0) (suc j) (suc (suc j)) -gcdsym1 (suc zero) i0 zero j0 = refl -gcdsym1 (suc (suc i)) i0 zero zero = refl -gcdsym1 (suc (suc i)) i0 zero (suc j0) = gcdsym1 (suc i) (suc (suc i))j0 (suc j0) -gcdsym1 (suc i) i0 (suc j) j0 = subst₂ (λ j k → j ≡ k ) (sym (gcd22 i _ _ _)) (sym (gcd22 j _ _ _)) (gcdsym1 i i0 j j0 ) - -gcdsym : { n m : ℕ} → gcd n m ≡ gcd m n -gcdsym {n} {m} = gcdsym1 n n m m - -gcd11 : ( i : ℕ ) → gcd i i ≡ i -gcd11 i = gcdmm i i - -gcd203 : (i : ℕ) → gcd1 (suc i) (suc i) i i ≡ 1 -gcd203 zero = refl -gcd203 (suc i) = gcd205 (suc i) where - gcd205 : (j : ℕ) → gcd1 (suc j) (suc (suc i)) j (suc i) ≡ 1 - gcd205 zero = refl - gcd205 (suc j) = subst (λ k → k ≡ 1) (gcd22 (suc j) (suc (suc i)) j (suc i)) (gcd205 j) -gcd204 : (i : ℕ) → gcd1 1 1 i i ≡ 1 -gcd204 zero = refl -gcd204 (suc zero) = refl -gcd204 (suc (suc zero)) = refl -gcd204 (suc (suc (suc i))) = gcd204 (suc (suc i)) - -gcd2 : ( i j : ℕ ) → gcd (i + j) j ≡ gcd i j -gcd2 i j = gcd200 i i j j refl refl where - gcd202 : (i j1 : ℕ) → (i + suc j1) ≡ suc (i + j1) - gcd202 zero j1 = refl - gcd202 (suc i) j1 = cong suc (gcd202 i j1) - gcd201 : (i i0 j j0 j1 : ℕ) → gcd1 (i + j1) (i0 + suc j) j1 j0 ≡ gcd1 i (i0 + suc j) zero j0 - gcd201 i i0 j j0 zero = subst (λ k → gcd1 k (i0 + suc j) zero j0 ≡ gcd1 i (i0 + suc j) zero j0 ) (+-comm zero i) refl - gcd201 i i0 j j0 (suc j1) = begin - gcd1 (i + suc j1) (i0 + suc j) (suc j1) j0 ≡⟨ cong (λ k → gcd1 k (i0 + suc j) (suc j1) j0 ) (gcd202 i j1) ⟩ - gcd1 (suc (i + j1)) (i0 + suc j) (suc j1) j0 ≡⟨ gcd22 (i + j1) (i0 + suc j) j1 j0 ⟩ - gcd1 (i + j1) (i0 + suc j) j1 j0 ≡⟨ gcd201 i i0 j j0 j1 ⟩ - gcd1 i (i0 + suc j) zero j0 ∎ where open ≡-Reasoning - gcd200 : (i i0 j j0 : ℕ) → i ≡ i0 → j ≡ j0 → gcd1 (i + j) (i0 + j) j j0 ≡ gcd1 i i j0 j0 - gcd200 i .i zero .0 refl refl = subst (λ k → gcd1 k k zero zero ≡ gcd1 i i zero zero ) (+-comm zero i) refl - gcd200 (suc (suc i)) i0 (suc j) (suc j0) i=i0 j=j0 = gcd201 (suc (suc i)) i0 j (suc j0) (suc j) - gcd200 zero zero (suc zero) .1 i=i0 refl = refl - gcd200 zero zero (suc (suc j)) .(suc (suc j)) i=i0 refl = begin - gcd1 (zero + suc (suc j)) (zero + suc (suc j)) (suc (suc j)) (suc (suc j)) ≡⟨ gcdmm (suc (suc j)) (suc (suc j)) ⟩ - suc (suc j) ≡⟨ sym (gcd20 (suc (suc j))) ⟩ - gcd1 zero zero (suc (suc j)) (suc (suc j)) ∎ where open ≡-Reasoning - gcd200 zero (suc i0) (suc j) .(suc j) () refl - gcd200 (suc zero) .1 (suc j) .(suc j) refl refl = begin - gcd1 (1 + suc j) (1 + suc j) (suc j) (suc j) ≡⟨ gcd203 (suc j) ⟩ - 1 ≡⟨ sym ( gcd204 (suc j)) ⟩ - gcd1 1 1 (suc j) (suc j) ∎ where open ≡-Reasoning - gcd200 (suc (suc i)) i0 (suc j) zero i=i0 () - -gcd52 : {i : ℕ } → 1 < suc (suc i) -gcd52 {zero} = a<sa -gcd52 {suc i} = <-trans (gcd52 {i}) a<sa - -gcd50 : (i i0 j j0 : ℕ) → 1 < i0 → i ≤ i0 → j ≤ j0 → gcd1 i i0 j j0 ≤ i0 -gcd50 zero i0 zero j0 0<i i<i0 j<j0 with <-cmp i0 j0 -... | tri< a ¬b ¬c = ≤-refl -... | tri≈ ¬a refl ¬c = ≤-refl -... | tri> ¬a ¬b c = ≤-trans refl-≤s c -gcd50 zero (suc i0) (suc zero) j0 0<i i<i0 j<j0 = gcd51 0<i where - gcd51 : 1 < suc i0 → gcd1 zero (suc i0) 1 j0 ≤ suc i0 - gcd51 1<i = ≤to< 1<i -gcd50 zero (suc i0) (suc (suc j)) j0 0<i i<i0 j<j0 = gcd50 i0 (suc i0) (suc j) (suc (suc j)) 0<i refl-≤s refl-≤s -gcd50 (suc zero) i0 zero j0 0<i i<i0 j<j0 = ≤to< 0<i -gcd50 (suc (suc i)) i0 zero zero 0<i i<i0 j<j0 = ≤-refl -gcd50 (suc (suc i)) i0 zero (suc j0) 0<i i<i0 j<j0 = ≤-trans (gcd50 (suc i) (suc (suc i)) j0 (suc j0) gcd52 refl-≤s refl-≤s) i<i0 -gcd50 (suc i) i0 (suc j) j0 0<i i<i0 j<j0 = subst (λ k → k ≤ i0 ) (sym (gcd22 i i0 j j0)) - (gcd50 i i0 j j0 0<i (≤-trans refl-≤s i<i0) (≤-trans refl-≤s j<j0)) - -gcd5 : ( n k : ℕ ) → 1 < n → gcd n k ≤ n -gcd5 n k 0<n = gcd50 n n k k 0<n ≤-refl ≤-refl - -gcd6 : ( n k : ℕ ) → 1 < n → gcd k n ≤ n -gcd6 n k 1<n = subst (λ m → m ≤ n) (gcdsym {n} {k}) (gcd5 n k 1<n) - -gcd4 : ( n k : ℕ ) → 1 < n → gcd n k ≡ k → k ≤ n -gcd4 n k 1<n eq = subst (λ m → m ≤ n ) eq (gcd5 n k 1<n) - -gcdmul+1 : ( m n : ℕ ) → gcd (m * n + 1) n ≡ 1 -gcdmul+1 zero n = gcd204 n -gcdmul+1 (suc m) n = begin - gcd (suc m * n + 1) n ≡⟨⟩ - gcd (n + m * n + 1) n ≡⟨ cong (λ k → gcd k n ) (begin - n + m * n + 1 ≡⟨ cong (λ k → k + 1) (+-comm n _) ⟩ - m * n + n + 1 ≡⟨ +-assoc (m * n) _ _ ⟩ - m * n + (n + 1) ≡⟨ cong (λ k → m * n + k) (+-comm n _) ⟩ - m * n + (1 + n) ≡⟨ sym ( +-assoc (m * n) _ _ ) ⟩ - m * n + 1 + n ∎ - ) ⟩ - gcd (m * n + 1 + n) n ≡⟨ gcd2 (m * n + 1) n ⟩ - gcd (m * n + 1) n ≡⟨ gcdmul+1 m n ⟩ - 1 ∎ where open ≡-Reasoning -
--- a/automaton-in-agda/src/agda/halt.agda Sun Jun 13 18:48:57 2021 +0900 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,114 +0,0 @@ -module halt where - -open import Level renaming ( zero to Zero ; suc to Suc ) -open import Data.Nat -open import Data.Maybe -open import Data.List hiding ([_]) -open import Data.Nat.Properties -open import Relation.Nullary -open import Data.Empty -open import Data.Unit -open import Relation.Binary.Core hiding (_⇔_) -open import Relation.Binary.Definitions -open import Relation.Binary.PropositionalEquality - -open import logic - -record HBijection {n m : Level} (R : Set n) (S : Set m) : Set (n Level.⊔ m) where - field - fun← : S → R - fun→ : R → S - fiso← : (x : R) → fun← ( fun→ x ) ≡ x --- normal bijection required below, but we don't need this to show the inconsistency --- fiso→ : (x : S ) → fun→ ( fun← x ) ≡ x - -injection : {n m : Level} (R : Set n) (S : Set m) (f : R → S ) → Set (n Level.⊔ m) -injection R S f = (x y : R) → f x ≡ f y → x ≡ y - -open HBijection - -diag : {S : Set } (b : HBijection ( S → Bool ) S) → S → Bool -diag b n = not (fun← b n n) - -diagonal : { S : Set } → ¬ HBijection ( S → Bool ) S -diagonal {S} b = diagn1 (fun→ b (diag b) ) refl where - diagn1 : (n : S ) → ¬ (fun→ b (diag b) ≡ n ) - diagn1 n dn = ¬t=f (diag b n ) ( begin - not (diag b n) - ≡⟨⟩ - not (not fun← b n n) - ≡⟨ cong (λ k → not (k n) ) (sym (fiso← b _)) ⟩ - not (fun← b (fun→ b (diag b)) n) - ≡⟨ cong (λ k → not (fun← b k n) ) dn ⟩ - not (fun← b n n) - ≡⟨⟩ - diag b n - ∎ ) where open ≡-Reasoning - -record TM : Set where - field - tm : List Bool → Maybe Bool - -open TM - -record UTM : Set where - field - utm : TM - encode : TM → List Bool - is-tm : (t : TM) → (x : List Bool) → tm utm (encode t ++ x ) ≡ tm t x - -open UTM - -open _∧_ - -open import Axiom.Extensionality.Propositional -postulate f-extensionality : { n : Level} → Axiom.Extensionality.Propositional.Extensionality n n - -record Halt : Set where - field - halt : (t : TM ) → (x : List Bool ) → Bool - is-halt : (t : TM ) → (x : List Bool ) → (halt t x ≡ true ) ⇔ ( (just true ≡ tm t x ) ∨ (just false ≡ tm t x ) ) - is-not-halt : (t : TM ) → (x : List Bool ) → (halt t x ≡ false ) ⇔ ( nothing ≡ tm t x ) - -open Halt - -TNL : (halt : Halt ) → (utm : UTM) → HBijection (List Bool → Bool) (List Bool) -TNL halt utm = record { - fun← = λ tm x → Halt.halt halt (UTM.utm utm) (tm ++ x) - ; fun→ = λ h → encode utm record { tm = h1 h } - ; fiso← = λ h → f-extensionality (λ y → TN1 h y ) - } where - open ≡-Reasoning - h1 : (h : List Bool → Bool) → (x : List Bool ) → Maybe Bool - h1 h x with h x - ... | true = just true - ... | false = nothing - tenc : (h : List Bool → Bool) → (y : List Bool) → List Bool - tenc h y = encode utm (record { tm = λ x → h1 h x }) ++ y - h-nothing : (h : List Bool → Bool) → (y : List Bool) → h y ≡ false → h1 h y ≡ nothing - h-nothing h y eq with h y - h-nothing h y refl | false = refl - h-just : (h : List Bool → Bool) → (y : List Bool) → h y ≡ true → h1 h y ≡ just true - h-just h y eq with h y - h-just h y refl | true = refl - TN1 : (h : List Bool → Bool) → (y : List Bool ) → Halt.halt halt (UTM.utm utm) (tenc h y) ≡ h y - TN1 h y with h y | inspect h y - ... | true | record { eq = eq1 } = begin - Halt.halt halt (UTM.utm utm) (tenc h y) ≡⟨ proj2 (is-halt halt (UTM.utm utm) (tenc h y) ) (case1 (sym tm-tenc)) ⟩ - true ∎ where - tm-tenc : tm (UTM.utm utm) (tenc h y) ≡ just true - tm-tenc = begin - tm (UTM.utm utm) (tenc h y) ≡⟨ is-tm utm _ y ⟩ - h1 h y ≡⟨ h-just h y eq1 ⟩ - just true ∎ - ... | false | record { eq = eq1 } = begin - Halt.halt halt (UTM.utm utm) (tenc h y) ≡⟨ proj2 (is-not-halt halt (UTM.utm utm) (tenc h y) ) (sym tm-tenc) ⟩ - false ∎ where - tm-tenc : tm (UTM.utm utm) (tenc h y) ≡ nothing - tm-tenc = begin - tm (UTM.utm utm) (tenc h y) ≡⟨ is-tm utm _ y ⟩ - h1 h y ≡⟨ h-nothing h y eq1 ⟩ - nothing ∎ - -- the rest of bijection means encoding is unique - -- fiso→ : (y : List Bool ) → encode utm record { tm = λ x → h1 (λ tm → Halt.halt halt (UTM.utm utm) tm ) x } ≡ y -
--- a/automaton-in-agda/src/agda/index.ind Sun Jun 13 18:48:57 2021 +0900 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,31 +0,0 @@ ---title: list -<a href=FSetUtil.agda> FSetUtil.agda </a><br> -<a href=automaton-ex.agda> automaton-ex.agda </a><br> -<a href=automaton.agda> automaton.agda </a><br> -<a href=cfg.agda> cfg.agda </a><br> -<a href=cfg1.agda> cfg1.agda </a><br> -<a href=chap0.agda> chap0.agda </a><br> -<a href=derive.agda> derive.agda </a><br> -<a href=even.agda> even.agda </a><br> -<a href=finiteSet.agda> finiteSet.agda </a><br> -<a href=flcagl.agda> flcagl.agda </a><br> -<a href=gcd.agda> gcd.agda </a><br> -<a href=halt.agda> halt.agda </a><br> -<a href=induction-ex.agda> induction-ex.agda </a><br> -<a href=lang-text.agda> lang-text.agda </a><br> -<a href=logic.agda> logic.agda </a><br> -<a href=nat.agda> nat.agda </a><br> -<a href=nfa.agda> nfa.agda </a><br> -<a href=nfa136.agda> nfa136.agda </a><br> -<a href=non-regular.agda> non-regular.agda </a><br> -<a href=omega-automaton.agda> omega-automaton.agda </a><br> -<a href=pushdown.agda> pushdown.agda </a><br> -<a href=puzzle.agda> puzzle.agda </a><br> -<a href=regex.agda> regex.agda </a><br> -<a href=regex1.agda> regex1.agda </a><br> -<a href=regular-concat.agda> regular-concat.agda </a><br> -<a href=regular-language.agda> regular-language.agda </a><br> -<a href=root2.agda> root2.agda </a><br> -<a href=sbconst2.agda> sbconst2.agda </a><br> -<a href=turing.agda> turing.agda </a><br> -<a href=utm.agda> utm.agda </a><br>
--- a/automaton-in-agda/src/agda/induction-ex.agda Sun Jun 13 18:48:57 2021 +0900 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,118 +0,0 @@ -{-# OPTIONS --guardedness #-} -module induction-ex where - -open import Relation.Binary.PropositionalEquality -open import Size -open import Data.Bool - -data List (A : Set ) : Set where - [] : List A - _∷_ : A → List A → List A - -data Nat : Set where - zero : Nat - suc : Nat → Nat - -add : Nat → Nat → Nat -add zero x = x -add (suc x) y = suc ( add x y ) - -_++_ : {A : Set} → List A → List A → List A -[] ++ y = y -(x ∷ t) ++ y = x ∷ ( t ++ y ) - -test1 = (zero ∷ []) ++ (zero ∷ []) - -length : {A : Set } → List A → Nat -length [] = zero -length (_ ∷ t) = suc ( length t ) - -lemma1 : {A : Set} → (x y : List A ) → length ( x ++ y ) ≡ add (length x) (length y) -lemma1 [] y = refl -lemma1 (x ∷ t) y = cong ( λ k → suc k ) lemma2 where - lemma2 : length (t ++ y) ≡ add (length t) (length y) - lemma2 = lemma1 t y - --- record List1 ( A : Set ) : Set where --- inductive --- field --- nil : List1 A --- cons : A → List1 A → List1 A --- --- record List2 ( A : Set ) : Set where --- coinductive --- field --- nil : List2 A --- cons : A → List2 A → List2 A - -data SList (i : Size) (A : Set) : Set where - []' : SList i A - _∷'_ : {j : Size< i} (x : A) (xs : SList j A) → SList i A - - -map : ∀{i A B} → (A → B) → SList i A → SList i B -map f []' = []' -map f ( x ∷' xs)= f x ∷' map f xs - -foldr : ∀{i} {A B : Set} → (A → B → B) → B → SList i A → B -foldr c n []' = n -foldr c n (x ∷' xs) = c x (foldr c n xs) - -any : ∀{i A} → (A → Bool) → SList i A → Bool -any p xs = foldr _∨_ false (map p xs) - --- Sappend : {A : Set } {i j : Size } → SList i A → SList j A → SList {!!} A --- Sappend []' y = y --- Sappend (x ∷' x₁) y = _∷'_ {?} x (Sappend x₁ y) - -language : { Σ : Set } → Set -language {Σ} = List Σ → Bool - -record Lang (i : Size) (A : Set) : Set where - coinductive - field - ν : Bool - δ : ∀{j : Size< i} → A → Lang j A - -open Lang - -∅ : ∀ {i A} → Lang i A -ν ∅ = false -δ ∅ _ = ∅ - -∅' : {i : Size } { A : Set } → Lang i A -∅' {i} {A} = record { ν = false ; δ = lemma3 } where - lemma3 : {j : Size< i} → A → Lang j A - lemma3 {j} _ = {!!} - -∅l : {A : Set } → language {A} -∅l _ = false - -ε : ∀ {i A} → Lang i A -ν ε = true -δ ε _ = ∅ - -εl : {A : Set } → language {A} -εl [] = true -εl (_ ∷ _) = false - -_+_ : ∀ {i A} → Lang i A → Lang i A → Lang i A -ν (a + b) = ν a ∨ ν b -δ (a + b) x = δ a x + δ b x - -Union : {Σ : Set} → ( A B : language {Σ} ) → language {Σ} -Union {Σ} A B x = (A x ) ∨ (B x) - -_·_ : ∀ {i A} → Lang i A → Lang i A → Lang i A -ν (a · b) = ν a ∧ ν b -δ (a · b) x = if (ν a) then ((δ a x · b ) + (δ b x )) else ( δ a x · b ) - -split : {Σ : Set} → (List Σ → Bool) - → ( List Σ → Bool) → List Σ → Bool -split x y [] = x [] ∨ y [] -split x y (h ∷ t) = (x [] ∧ y (h ∷ t)) ∨ - split (λ t1 → x ( h ∷ t1 )) (λ t2 → y t2 ) t - -Concat : {Σ : Set} → ( A B : language {Σ} ) → language {Σ} -Concat {Σ} A B = split A B -
--- a/automaton-in-agda/src/agda/lang-text.agda Sun Jun 13 18:48:57 2021 +0900 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,54 +0,0 @@ -module lang-text where - -open import Data.List -open import Data.String -open import Data.Char -open import Data.Char.Unsafe -open import Relation.Binary.PropositionalEquality -open import Relation.Nullary -open import logic - -split : {Σ : Set} → (List Σ → Bool) - → ( List Σ → Bool) → List Σ → Bool -split x y [] = x [] /\ y [] -split x y (h ∷ t) = (x [] /\ y (h ∷ t)) \/ - split (λ t1 → x ( h ∷ t1 )) (λ t2 → y t2 ) t - -contains : String → String → Bool -contains x y = contains1 (toList x ) ( toList y ) where - contains1 : List Char → List Char → Bool - contains1 [] [] = false - contains1 [] ( cx ∷ ly ) = false - contains1 (cx ∷ lx) [] = true - contains1 (cx ∷ lx ) ( cy ∷ ly ) with cx ≟ cy - ... | yes refl = contains1 lx ly - ... | no n = false - --- w does not contain the substring ab -ex15a : Set -ex15a = (w : String ) → ¬ (contains w "ab" ≡ true ) - --- w does not contains substring baba -ex15b : Set -ex15b = (w : String ) → ¬ (contains w "baba" ≡ true ) - --- w contains neither the substing ab nor ba -ex15c : Set - --- w is any string not in a*b* -ex15c = (w : String ) → ( ¬ (contains w "ab" ≡ true ) /\ ( ¬ (contains w "ba" ≡ true ) - -ex15d : {!!} -ex15d = {!!} - -ex15e : {!!} -ex15e = {!!} - -ex15f : {!!} -ex15f = {!!} - -ex15g : {!!} -ex15g = {!!} - -ex15h : {!!} -ex15h = {!!}
--- a/automaton-in-agda/src/agda/logic.agda Sun Jun 13 18:48:57 2021 +0900 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,154 +0,0 @@ -module logic where - -open import Level -open import Relation.Nullary -open import Relation.Binary hiding (_⇔_ ) -open import Data.Empty - - -data Bool : Set where - true : Bool - false : Bool - -record _∧_ {n m : Level} (A : Set n) ( B : Set m ) : Set (n ⊔ m) where - constructor ⟪_,_⟫ - field - proj1 : A - proj2 : B - -data _∨_ {n m : Level} (A : Set n) ( B : Set m ) : Set (n ⊔ m) where - case1 : A → A ∨ B - case2 : B → A ∨ B - -_⇔_ : {n m : Level } → ( A : Set n ) ( B : Set m ) → Set (n ⊔ m) -_⇔_ A B = ( A → B ) ∧ ( B → A ) - -contra-position : {n m : Level } {A : Set n} {B : Set m} → (A → B) → ¬ B → ¬ A -contra-position {n} {m} {A} {B} f ¬b a = ¬b ( f a ) - -double-neg : {n : Level } {A : Set n} → A → ¬ ¬ A -double-neg A notnot = notnot A - -double-neg2 : {n : Level } {A : Set n} → ¬ ¬ ¬ A → ¬ A -double-neg2 notnot A = notnot ( double-neg A ) - -de-morgan : {n : Level } {A B : Set n} → A ∧ B → ¬ ( (¬ A ) ∨ (¬ B ) ) -de-morgan {n} {A} {B} and (case1 ¬A) = ⊥-elim ( ¬A ( _∧_.proj1 and )) -de-morgan {n} {A} {B} and (case2 ¬B) = ⊥-elim ( ¬B ( _∧_.proj2 and )) - -dont-or : {n m : Level} {A : Set n} { B : Set m } → A ∨ B → ¬ A → B -dont-or {A} {B} (case1 a) ¬A = ⊥-elim ( ¬A a ) -dont-or {A} {B} (case2 b) ¬A = b - -dont-orb : {n m : Level} {A : Set n} { B : Set m } → A ∨ B → ¬ B → A -dont-orb {A} {B} (case2 b) ¬B = ⊥-elim ( ¬B b ) -dont-orb {A} {B} (case1 a) ¬B = a - -infixr 130 _∧_ -infixr 140 _∨_ -infixr 150 _⇔_ - -_/\_ : Bool → Bool → Bool -true /\ true = true -_ /\ _ = false - -_\/_ : Bool → Bool → Bool -false \/ false = false -_ \/ _ = true - -not_ : Bool → Bool -not true = false -not false = true - -_<=>_ : Bool → Bool → Bool -true <=> true = true -false <=> false = true -_ <=> _ = false - -open import Relation.Binary.PropositionalEquality - -¬t=f : (t : Bool ) → ¬ ( not t ≡ t) -¬t=f true () -¬t=f false () - -infixr 130 _\/_ -infixr 140 _/\_ - -≡-Bool-func : {A B : Bool } → ( A ≡ true → B ≡ true ) → ( B ≡ true → A ≡ true ) → A ≡ B -≡-Bool-func {true} {true} a→b b→a = refl -≡-Bool-func {false} {true} a→b b→a with b→a refl -... | () -≡-Bool-func {true} {false} a→b b→a with a→b refl -... | () -≡-Bool-func {false} {false} a→b b→a = refl - -bool-≡-? : (a b : Bool) → Dec ( a ≡ b ) -bool-≡-? true true = yes refl -bool-≡-? true false = no (λ ()) -bool-≡-? false true = no (λ ()) -bool-≡-? false false = yes refl - -¬-bool-t : {a : Bool} → ¬ ( a ≡ true ) → a ≡ false -¬-bool-t {true} ne = ⊥-elim ( ne refl ) -¬-bool-t {false} ne = refl - -¬-bool-f : {a : Bool} → ¬ ( a ≡ false ) → a ≡ true -¬-bool-f {true} ne = refl -¬-bool-f {false} ne = ⊥-elim ( ne refl ) - -¬-bool : {a : Bool} → a ≡ false → a ≡ true → ⊥ -¬-bool refl () - -lemma-∧-0 : {a b : Bool} → a /\ b ≡ true → a ≡ false → ⊥ -lemma-∧-0 {true} {true} refl () -lemma-∧-0 {true} {false} () -lemma-∧-0 {false} {true} () -lemma-∧-0 {false} {false} () - -lemma-∧-1 : {a b : Bool} → a /\ b ≡ true → b ≡ false → ⊥ -lemma-∧-1 {true} {true} refl () -lemma-∧-1 {true} {false} () -lemma-∧-1 {false} {true} () -lemma-∧-1 {false} {false} () - -bool-and-tt : {a b : Bool} → a ≡ true → b ≡ true → ( a /\ b ) ≡ true -bool-and-tt refl refl = refl - -bool-∧→tt-0 : {a b : Bool} → ( a /\ b ) ≡ true → a ≡ true -bool-∧→tt-0 {true} {true} refl = refl -bool-∧→tt-0 {false} {_} () - -bool-∧→tt-1 : {a b : Bool} → ( a /\ b ) ≡ true → b ≡ true -bool-∧→tt-1 {true} {true} refl = refl -bool-∧→tt-1 {true} {false} () -bool-∧→tt-1 {false} {false} () - -bool-or-1 : {a b : Bool} → a ≡ false → ( a \/ b ) ≡ b -bool-or-1 {false} {true} refl = refl -bool-or-1 {false} {false} refl = refl -bool-or-2 : {a b : Bool} → b ≡ false → (a \/ b ) ≡ a -bool-or-2 {true} {false} refl = refl -bool-or-2 {false} {false} refl = refl - -bool-or-3 : {a : Bool} → ( a \/ true ) ≡ true -bool-or-3 {true} = refl -bool-or-3 {false} = refl - -bool-or-31 : {a b : Bool} → b ≡ true → ( a \/ b ) ≡ true -bool-or-31 {true} {true} refl = refl -bool-or-31 {false} {true} refl = refl - -bool-or-4 : {a : Bool} → ( true \/ a ) ≡ true -bool-or-4 {true} = refl -bool-or-4 {false} = refl - -bool-or-41 : {a b : Bool} → a ≡ true → ( a \/ b ) ≡ true -bool-or-41 {true} {b} refl = refl - -bool-and-1 : {a b : Bool} → a ≡ false → (a /\ b ) ≡ false -bool-and-1 {false} {b} refl = refl -bool-and-2 : {a b : Bool} → b ≡ false → (a /\ b ) ≡ false -bool-and-2 {true} {false} refl = refl -bool-and-2 {false} {false} refl = refl - -
--- a/automaton-in-agda/src/agda/nfa.agda Sun Jun 13 18:48:57 2021 +0900 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,152 +0,0 @@ -{-# OPTIONS --allow-unsolved-metas #-} -module nfa where - --- open import Level renaming ( suc to succ ; zero to Zero ) -open import Data.Nat -open import Data.List -open import Data.Fin hiding ( _<_ ) -open import Data.Maybe -open import Relation.Nullary -open import Data.Empty --- open import Data.Bool using ( Bool ; true ; false ; _∧_ ; _∨_ ) -open import Relation.Binary.PropositionalEquality hiding ( [_] ) -open import Relation.Nullary using (¬_; Dec; yes; no) -open import logic - -data States1 : Set where - sr : States1 - ss : States1 - st : States1 - -data In2 : Set where - i0 : In2 - i1 : In2 - - -record NAutomaton ( Q : Set ) ( Σ : Set ) - : Set where - field - Nδ : Q → Σ → Q → Bool - Nend : Q → Bool - -open NAutomaton - -LStates1 : List States1 -LStates1 = sr ∷ ss ∷ st ∷ [] - --- one of qs q is true -existsS1 : ( States1 → Bool ) → Bool -existsS1 qs = qs sr \/ qs ss \/ qs st - --- extract list of q which qs q is true -to-listS1 : ( States1 → Bool ) → List States1 -to-listS1 qs = ss1 LStates1 where - ss1 : List States1 → List States1 - ss1 [] = [] - ss1 (x ∷ t) with qs x - ... | true = x ∷ ss1 t - ... | false = ss1 t - -Nmoves : { Q : Set } { Σ : Set } - → NAutomaton Q Σ - → (exists : ( Q → Bool ) → Bool) - → ( Qs : Q → Bool ) → (s : Σ ) → Q → Bool -Nmoves {Q} { Σ} M exists Qs s q = - exists ( λ qn → (Qs qn /\ ( Nδ M qn s q ) )) - -Naccept : { Q : Set } { Σ : Set } - → NAutomaton Q Σ - → (exists : ( Q → Bool ) → Bool) - → (Nstart : Q → Bool) → List Σ → Bool -Naccept M exists sb [] = exists ( λ q → sb q /\ Nend M q ) -Naccept M exists sb (i ∷ t ) = Naccept M exists (λ q → exists ( λ qn → (sb qn /\ ( Nδ M qn i q ) ))) t - -Ntrace : { Q : Set } { Σ : Set } - → NAutomaton Q Σ - → (exists : ( Q → Bool ) → Bool) - → (to-list : ( Q → Bool ) → List Q ) - → (Nstart : Q → Bool) → List Σ → List (List Q) -Ntrace M exists to-list sb [] = to-list ( λ q → sb q /\ Nend M q ) ∷ [] -Ntrace M exists to-list sb (i ∷ t ) = - to-list (λ q → sb q ) ∷ - Ntrace M exists to-list (λ q → exists ( λ qn → (sb qn /\ ( Nδ M qn i q ) ))) t - - -transition3 : States1 → In2 → States1 → Bool -transition3 sr i0 sr = true -transition3 sr i1 ss = true -transition3 sr i1 sr = true -transition3 ss i0 sr = true -transition3 ss i1 st = true -transition3 st i0 sr = true -transition3 st i1 st = true -transition3 _ _ _ = false - -fin1 : States1 → Bool -fin1 st = true -fin1 ss = false -fin1 sr = false - -test5 = existsS1 (λ q → fin1 q ) -test6 = to-listS1 (λ q → fin1 q ) - -start1 : States1 → Bool -start1 sr = true -start1 _ = false - -am2 : NAutomaton States1 In2 -am2 = record { Nδ = transition3 ; Nend = fin1} - -example2-1 = Naccept am2 existsS1 start1 ( i0 ∷ i1 ∷ i0 ∷ [] ) -example2-2 = Naccept am2 existsS1 start1 ( i1 ∷ i1 ∷ i1 ∷ [] ) - -t-1 : List ( List States1 ) -t-1 = Ntrace am2 existsS1 to-listS1 start1 ( i1 ∷ i1 ∷ i1 ∷ [] ) -t-2 = Ntrace am2 existsS1 to-listS1 start1 ( i0 ∷ i1 ∷ i0 ∷ [] ) - -transition4 : States1 → In2 → States1 → Bool -transition4 sr i0 sr = true -transition4 sr i1 ss = true -transition4 sr i1 sr = true -transition4 ss i0 ss = true -transition4 ss i1 st = true -transition4 st i0 st = true -transition4 st i1 st = true -transition4 _ _ _ = false - -fin4 : States1 → Bool -fin4 st = true -fin4 _ = false - -start4 : States1 → Bool -start4 ss = true -start4 _ = false - -am4 : NAutomaton States1 In2 -am4 = record { Nδ = transition4 ; Nend = fin4} - -example4-1 = Naccept am4 existsS1 start4 ( i0 ∷ i1 ∷ i1 ∷ i0 ∷ [] ) -example4-2 = Naccept am4 existsS1 start4 ( i0 ∷ i1 ∷ i1 ∷ i1 ∷ [] ) - -fin0 : States1 → Bool -fin0 st = false -fin0 ss = false -fin0 sr = false - -test0 : Bool -test0 = existsS1 fin0 - -test1 : Bool -test1 = existsS1 fin1 - -test2 = Nmoves am2 existsS1 start1 - -open import automaton - -am2def : Automaton (States1 → Bool ) In2 -am2def = record { δ = λ qs s q → existsS1 (λ qn → qs q /\ Nδ am2 q s qn ) - ; aend = λ qs → existsS1 (λ q → qs q /\ Nend am2 q) } - -dexample4-1 = accept am2def start1 ( i0 ∷ i1 ∷ i1 ∷ i0 ∷ [] ) -texample4-1 = trace am2def start1 ( i0 ∷ i1 ∷ i1 ∷ i0 ∷ [] ) -
--- a/automaton-in-agda/src/agda/nfa136.agda Sun Jun 13 18:48:57 2021 +0900 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,113 +0,0 @@ -module nfa136 where - -open import logic -open import nfa -open import automaton -open import Data.List -open import finiteSet -open import Data.Fin -open import Relation.Binary.PropositionalEquality hiding ( [_] ) - -data StatesQ : Set where - q1 : StatesQ - q2 : StatesQ - q3 : StatesQ - -data A2 : Set where - a0 : A2 - b0 : A2 - -finStateQ : FiniteSet StatesQ -finStateQ = record { - Q←F = Q←F - ; F←Q = F←Q - ; finiso→ = finiso→ - ; finiso← = finiso← - } where - Q←F : Fin 3 → StatesQ - Q←F zero = q1 - Q←F (suc zero) = q2 - Q←F (suc (suc zero)) = q3 - F←Q : StatesQ → Fin 3 - F←Q q1 = zero - F←Q q2 = suc zero - F←Q q3 = suc (suc zero) - finiso→ : (q : StatesQ) → Q←F (F←Q q) ≡ q - finiso→ q1 = refl - finiso→ q2 = refl - finiso→ q3 = refl - finiso← : (f : Fin 3) → F←Q (Q←F f) ≡ f - finiso← zero = refl - finiso← (suc zero) = refl - finiso← (suc (suc zero)) = refl - finiso← (suc (suc (suc ()))) - -transition136 : StatesQ → A2 → StatesQ → Bool -transition136 q1 b0 q2 = true -transition136 q1 a0 q1 = true -- q1 → ep → q3 -transition136 q2 a0 q2 = true -transition136 q2 a0 q3 = true -transition136 q2 b0 q3 = true -transition136 q3 a0 q1 = true -transition136 _ _ _ = false - -end136 : StatesQ → Bool -end136 q1 = true -end136 _ = false - -start136 : StatesQ → Bool -start136 q1 = true -start136 _ = false - -exists136 : (StatesQ → Bool) → Bool -exists136 f = f q1 \/ f q2 \/ f q3 - -to-list-136 : (StatesQ → Bool) → List StatesQ -to-list-136 f = tl1 where - tl3 : List StatesQ - tl3 with f q3 - ... | true = q3 ∷ [] - ... | false = [] - tl2 : List StatesQ - tl2 with f q2 - ... | true = q2 ∷ tl3 - ... | false = tl3 - tl1 : List StatesQ - tl1 with f q1 - ... | true = q1 ∷ tl2 - ... | false = tl2 - -nfa136 : NAutomaton StatesQ A2 -nfa136 = record { Nδ = transition136; Nend = end136 } - -example136-1 = Naccept nfa136 exists136 start136( a0 ∷ b0 ∷ a0 ∷ a0 ∷ [] ) - -t146-1 = Ntrace nfa136 exists136 to-list-136 start136( a0 ∷ b0 ∷ a0 ∷ a0 ∷ [] ) - -example136-0 = Naccept nfa136 exists136 start136( a0 ∷ [] ) - -example136-2 = Naccept nfa136 exists136 start136( b0 ∷ a0 ∷ b0 ∷ a0 ∷ b0 ∷ [] ) -t146-2 = Ntrace nfa136 exists136 to-list-136 start136( b0 ∷ a0 ∷ b0 ∷ a0 ∷ b0 ∷ [] ) - -open FiniteSet - -nx : (StatesQ → Bool) → (List A2 ) → StatesQ → Bool -nx now [] = now -nx now ( i ∷ ni ) = (Nmoves nfa136 exists136 (nx now ni) i ) - -example136-3 = to-list-136 start136 -example136-4 = to-list-136 (nx start136 ( a0 ∷ b0 ∷ a0 ∷ [] )) - -open import sbconst2 - -fm136 : Automaton ( StatesQ → Bool ) A2 -fm136 = subset-construction exists136 nfa136 - -open NAutomaton - -lemma136 : ( x : List A2 ) → Naccept nfa136 exists136 start136 x ≡ accept fm136 start136 x -lemma136 x = lemma136-1 x start136 where - lemma136-1 : ( x : List A2 ) → ( states : StatesQ → Bool ) - → Naccept nfa136 exists136 states x ≡ accept fm136 states x - lemma136-1 [] _ = refl - lemma136-1 (h ∷ t) states = lemma136-1 t (δconv exists136 (Nδ nfa136) states h)
--- a/automaton-in-agda/src/agda/non-regular.agda Sun Jun 13 18:48:57 2021 +0900 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,20 +0,0 @@ -module non-regular where - -open import Data.Nat -open import Data.List -open import Relation.Binary.PropositionalEquality hiding ( [_] ) -open import logic -open import automaton -open import finiteSet -open import Relation.Nullary - -inputnn : ( n : ℕ ) → { Σ : Set } → ( x y : Σ ) → List Σ → List Σ -inputnn zero {_} _ _ s = s -inputnn (suc n) x y s = x ∷ ( inputnn n x y ( y ∷ s ) ) - -lemmaNN : { Q : Set } { Σ : Set } → ( x y : Σ ) → ¬ (x ≡ y) - → FiniteSet Q - → (M : Automaton Q Σ) (q : Q) - → ¬ ( (n : ℕ) → accept M q ( inputnn n x y [] ) ≡ true ) -lemmaNN = {!!} -
--- a/automaton-in-agda/src/agda/omega-automaton.agda Sun Jun 13 18:48:57 2021 +0900 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,155 +0,0 @@ -module omega-automaton where - -open import Level renaming ( suc to succ ; zero to Zero ) -open import Data.Nat -open import Data.List -open import Data.Maybe --- open import Data.Bool using ( Bool ; true ; false ; _∧_ ) renaming ( not to negate ) -open import Relation.Binary.PropositionalEquality hiding ( [_] ) -open import Relation.Nullary -- using (not_; Dec; yes; no) -open import Data.Empty - -open import logic -open import automaton - -open Automaton - -ω-run : { Q Σ : Set } → (Ω : Automaton Q Σ ) → (astart : Q ) → ℕ → ( ℕ → Σ ) → Q -ω-run Ω x zero s = x -ω-run Ω x (suc n) s = δ Ω (ω-run Ω x n s) ( s n ) - --- --- accept as Buchi automaton --- -record Buchi { Q Σ : Set } (Ω : Automaton Q Σ ) ( S : ℕ → Σ ) : Set where - field - from : ℕ - stay : (x : Q) → (n : ℕ ) → n > from → aend Ω ( ω-run Ω x n S ) ≡ true - -open Buchi - --- after sometimes, always p --- --- not p --- ------------> --- <> [] p * <> [] p --- <----------- --- p - - --- --- accept as Muller automaton --- -record Muller { Q Σ : Set } (Ω : Automaton Q Σ ) ( S : ℕ → Σ ) : Set where - field - next : (n : ℕ ) → ℕ - infinite : (x : Q) → (n : ℕ ) → aend Ω ( ω-run Ω x (n + (next n)) S ) ≡ true - --- always sometimes p --- --- not p --- ------------> --- [] <> p * [] <> p --- <----------- --- p - -data States3 : Set where - ts* : States3 - ts : States3 - -transition3 : States3 → Bool → States3 -transition3 ts* true = ts* -transition3 ts* false = ts -transition3 ts true = ts* -transition3 ts false = ts - -mark1 : States3 → Bool -mark1 ts* = true -mark1 ts = false - -ωa1 : Automaton States3 Bool -ωa1 = record { - δ = transition3 - ; aend = mark1 - } - -true-seq : ℕ → Bool -true-seq _ = true - -false-seq : ℕ → Bool -false-seq _ = false - -flip-seq : ℕ → Bool -flip-seq zero = false -flip-seq (suc n) = not ( flip-seq n ) - -lemma0 : Muller ωa1 flip-seq -lemma0 = record { - next = λ n → suc (suc n) - ; infinite = lemma01 - } where - lemma01 : (x : States3) (n : ℕ) → - aend ωa1 (ω-run ωa1 x (n + suc (suc n)) flip-seq) ≡ true - lemma01 = {!!} - -lemma1 : Buchi ωa1 true-seq -lemma1 = record { - from = zero - ; stay = {!!} - } where - lem1 : ( n : ℕ ) → n > zero → aend ωa1 (ω-run ωa1 {!!} n true-seq ) ≡ true - lem1 zero () - lem1 (suc n) (s≤s z≤n) with ω-run ωa1 {!!} n true-seq - lem1 (suc n) (s≤s z≤n) | ts* = {!!} - lem1 (suc n) (s≤s z≤n) | ts = {!!} - -ωa2 : Automaton States3 Bool -ωa2 = record { - δ = transition3 - ; aend = λ x → not ( mark1 x ) - } - -flip-dec : (n : ℕ ) → Dec ( flip-seq n ≡ true ) -flip-dec n with flip-seq n -flip-dec n | false = no λ () -flip-dec n | true = yes refl - -flip-dec1 : (n : ℕ ) → flip-seq (suc n) ≡ ( not ( flip-seq n ) ) -flip-dec1 n = let open ≡-Reasoning in - flip-seq (suc n ) - ≡⟨⟩ - ( not ( flip-seq n ) ) - ∎ - -flip-dec2 : (n : ℕ ) → not flip-seq (suc n) ≡ flip-seq n -flip-dec2 n = {!!} - - -record flipProperty : Set where - field - flipP : (n : ℕ) → ω-run ωa2 {!!} {!!} ≡ ω-run ωa2 {!!} {!!} - -lemma2 : Muller ωa2 flip-seq -lemma2 = record { - next = next - ; infinite = {!!} - } where - next : ℕ → ℕ - next = {!!} - infinite' : (n m : ℕ) → n ≥″ m → aend ωa2 {!!} ≡ true → aend ωa2 {!!} ≡ true - infinite' = {!!} - infinite : (n : ℕ) → aend ωa2 {!!} ≡ true - infinite = {!!} - -lemma3 : Buchi ωa1 false-seq → ⊥ -lemma3 = {!!} - -lemma4 : Muller ωa1 flip-seq → ⊥ -lemma4 = {!!} - - - - - - -
--- a/automaton-in-agda/src/agda/prime.agda Sun Jun 13 18:48:57 2021 +0900 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,51 +0,0 @@ -module prime where - -open import Data.Nat -open import Data.Nat.Properties -open import Data.Empty -open import Data.Unit using (⊤ ; tt) -open import Relation.Nullary -open import Relation.Binary.PropositionalEquality -open import Relation.Binary.Definitions - -open import gcd -open import nat - -record Prime (i : ℕ ) : Set where - field - isPrime : ( j : ℕ ) → j < i → gcd i j ≡ 1 - -open ≡-Reasoning - -record NonPrime ( n : ℕ ) : Set where - field - factor : ℕ - prime : Prime factor - dividable : Dividable factor n - -isPrime : ( n : ℕ ) → Dec ( Prime n ) -isPrime = {!!} - -nonPrime : ( n : ℕ ) → ¬ Prime n → NonPrime n -nonPrime n np = np1 n (λ j n≤j j<n → ⊥-elim (nat-≤> n≤j j<n ) ) where - np1 : ( m : ℕ ) → ( (j : ℕ ) → m ≤ j → j < n → gcd n j ≡ 1 ) → NonPrime n - np1 zero mg = ⊥-elim ( np record { isPrime = λ j lt → mg j z≤n lt } ) -- zero < j , j < n - np1 (suc m) mg with <-cmp ( gcd n (suc m) ) 1 - ... | tri< a ¬b ¬c = {!!} - ... | tri≈ ¬a b ¬c = np1 m {!!} - ... | tri> ¬a ¬b c = record { factor = gcd n (suc m) ; prime = {!!} ; dividable = record { factor = {!!} ; is-factor = {!!} } } - -prime-is-infinite : (max-prime : ℕ ) → ¬ ( (j : ℕ) → max-prime < j → ¬ Prime j ) -prime-is-infinite zero pmax = pmax 1 {!!} record { isPrime = λ n lt → {!!} } -prime-is-infinite (suc m) pmax = pmax (suc (factorial (suc m))) f>m record { isPrime = λ n lt → fact n lt } where - factorial : (n : ℕ) → ℕ - factorial zero = 1 - factorial (suc n) = (suc n) * (factorial n) - f>m : suc m < suc (factorial (suc m)) - f>m = {!!} - factm : (n m : ℕ ) → n < (suc m) → Dividable n (factorial m ) - factm = {!!} - fact : (n : ℕ ) → n < (suc (factorial (suc m))) → gcd (suc (factorial (suc m))) n ≡ 1 - fact n lt = fact12 (nonPrime (factorial (suc m )) ( pmax (factorial (suc m )) {!!} )) where - fact12 : NonPrime (factorial (suc m)) → gcd (suc (factorial (suc m))) n ≡ 1 - fact12 np = {!!}
--- a/automaton-in-agda/src/agda/pushdown.agda Sun Jun 13 18:48:57 2021 +0900 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,118 +0,0 @@ -module pushdown where - -open import Level renaming ( suc to succ ; zero to Zero ) -open import Data.Nat -open import Data.List -open import Data.Maybe -open import Data.Bool using ( Bool ; true ; false ) -open import Relation.Binary.PropositionalEquality hiding ( [_] ) -open import Relation.Nullary using (¬_; Dec; yes; no) -open import Level renaming ( suc to succ ; zero to Zero ) -open import Data.Product - - -data PushDown ( Γ : Set ) : Set where - pop : PushDown Γ - push : Γ → PushDown Γ - - -record PushDownAutomaton ( Q : Set ) ( Σ : Set ) ( Γ : Set ) - : Set where - field - pδ : Q → Σ → Γ → Q × ( PushDown Γ ) - pok : Q → Bool - pempty : Γ - pmoves : Q → List Γ → Σ → ( Q × List Γ ) - pmoves q [] i with pδ q i pempty - pmoves q [] i | qn , pop = ( qn , [] ) - pmoves q [] i | qn , push x = ( qn , ( x ∷ [] ) ) - pmoves q ( H ∷ T ) i with pδ q i H - pmoves q (H ∷ T) i | qn , pop = ( qn , T ) - pmoves q (H ∷ T) i | qn , push x = ( qn , ( x ∷ H ∷ T) ) - - paccept : (q : Q ) ( In : List Σ ) ( sp : List Γ ) → Bool - paccept q [] [] = pok q - paccept q ( H ∷ T) [] with pδ q H pempty - paccept q (H ∷ T) [] | qn , pop = paccept qn T [] - paccept q (H ∷ T) [] | qn , push x = paccept qn T (x ∷ [] ) - paccept q [] (_ ∷ _ ) = false - paccept q ( H ∷ T ) ( SH ∷ ST ) with pδ q H SH - ... | (nq , pop ) = paccept nq T ST - ... | (nq , push ns ) = paccept nq T ( ns ∷ SH ∷ ST ) - - --- 0011 --- 00000111111 -inputnn : ( n : ℕ ) → { Σ : Set } → ( x y : Σ ) → List Σ → List Σ -inputnn zero {_} _ _ s = s -inputnn (suc n) x y s = x ∷ ( inputnn n x y ( y ∷ s ) ) - - -data States0 : Set where - sr : States0 - -data In2 : Set where - i0 : In2 - i1 : In2 - -test0 = inputnn 5 i0 i1 [] - -pnn : PushDownAutomaton States0 In2 States0 -pnn = record { - pδ = pδ - ; pempty = sr - ; pok = λ q → true - } where - pδ : States0 → In2 → States0 → States0 × PushDown States0 - pδ sr i0 _ = (sr , push sr) - pδ sr i1 _ = (sr , pop ) - -data States1 : Set where - ss : States1 - st : States1 - -pn1 : PushDownAutomaton States1 In2 States1 -pn1 = record { - pδ = pδ - ; pempty = ss - ; pok = pok1 - } where - pok1 : States1 → Bool - pok1 ss = false - pok1 st = true - pδ : States1 → In2 → States1 → States1 × PushDown States1 - pδ ss i0 _ = (ss , push ss) - pδ ss i1 _ = (st , pop) - pδ st i0 _ = (st , push ss) - pδ st i1 _ = (st , pop ) - -test1 = PushDownAutomaton.paccept pnn sr ( i0 ∷ i0 ∷ i1 ∷ i1 ∷ [] ) [] -test2 = PushDownAutomaton.paccept pnn sr ( i0 ∷ i0 ∷ i1 ∷ i0 ∷ [] ) [] -test3 = PushDownAutomaton.pmoves pnn sr [] i0 -test4 = PushDownAutomaton.paccept pnn sr ( i0 ∷ i0 ∷ i1 ∷ i1 ∷ i0 ∷ i1 ∷ [] ) [] - -test5 = PushDownAutomaton.paccept pn1 ss ( i0 ∷ i0 ∷ i1 ∷ i1 ∷ [] ) [] -test6 = PushDownAutomaton.paccept pn1 ss ( i0 ∷ i0 ∷ i1 ∷ i1 ∷ i0 ∷ i1 ∷ [] ) [] - -open import Data.Empty - -test70 : (n : ℕ ) → (x : List In2) → PushDownAutomaton.paccept pnn sr x [] ≡ true → inputnn n i0 i1 [] ≡ x -test70 zero [] refl = refl -test70 zero (x ∷ y) pa = ⊥-elim (test701 pa) where - test701 : PushDownAutomaton.paccept pnn sr (x ∷ y) [] ≡ true → ⊥ - test701 pa with PushDownAutomaton.pδ pnn sr x sr - ... | sr , pop = {!!} - ... | sr , push x = {!!} -test70 (suc n) x pa = {!!} - -test71 : (n : ℕ ) → (x : List In2) → inputnn n i0 i1 [] ≡ x → PushDownAutomaton.paccept pnn sr x [] ≡ true -test71 = {!!} - -test7 : (n : ℕ ) → PushDownAutomaton.paccept pnn sr (inputnn n i0 i1 []) [] ≡ true -test7 zero = refl -test7 (suc n) with test7 n -... | t = test7lem [] t where - test7lem : (x : List States0) → PushDownAutomaton.paccept pnn sr (inputnn n i0 i1 []) x ≡ true - → PushDownAutomaton.paccept pnn sr (inputnn n i0 i1 (i1 ∷ [])) (sr ∷ x) ≡ true - test7lem x with PushDownAutomaton.paccept pnn sr (inputnn (suc n) i0 i1 []) (sr ∷ x) - ... | t2 = {!!}
--- a/automaton-in-agda/src/agda/puzzle.agda Sun Jun 13 18:48:57 2021 +0900 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,194 +0,0 @@ -module puzzle where - ----- 仮定 --- 猫か犬を飼っている人は山羊を飼ってない --- 猫を飼ってない人は、犬かウサギを飼っている --- 猫も山羊も飼っていない人は、ウサギを飼っている --- ----- 問題 --- 山羊を飼っている人は、犬を飼っていない --- 山羊を飼っている人は、ウサギを飼っている --- ウサギを飼っていない人は、猫を飼っている - -module pet-research where - open import logic - open import Relation.Nullary - open import Data.Empty - - postulate - lem : (a : Set) → a ∨ ( ¬ a ) - - record PetResearch ( Cat Dog Goat Rabbit : Set ) : Set where - field - fact1 : ( Cat ∨ Dog ) → ¬ Goat - fact2 : ¬ Cat → ( Dog ∨ Rabbit ) - fact3 : ¬ ( Cat ∨ Goat ) → Rabbit - - module tmp ( Cat Dog Goat Rabbit : Set ) (p : PetResearch Cat Dog Goat Rabbit ) where - - open PetResearch - - problem0 : Cat ∨ Dog ∨ Goat ∨ Rabbit - problem0 with lem Cat | lem Goat - ... | case1 c | g = case1 c - ... | c | case1 g = case2 ( case2 ( case1 g ) ) - ... | case2 ¬c | case2 ¬g = case2 ( case2 ( case2 ( fact3 p lemma1 ))) where - lemma1 : ¬ ( Cat ∨ Goat ) - lemma1 (case1 c) = ¬c c - lemma1 (case2 g) = ¬g g - - problem1 : Goat → ¬ Dog - problem1 g d = fact1 p (case2 d) g - - problem2 : Goat → Rabbit - problem2 g with lem Cat | lem Dog - problem2 g | case1 c | d = ⊥-elim ( fact1 p (case1 c ) g ) - problem2 g | case2 ¬c | case1 d = ⊥-elim ( fact1 p (case2 d ) g ) - problem2 g | case2 ¬c | case2 ¬d with lem Rabbit - ... | case1 r = r - ... | case2 ¬r = fact3 p lemma2 where - lemma2 : ¬ ( Cat ∨ Goat ) - lemma2 (case1 c) = ¬c c - lemma2 (case2 g) with fact2 p ¬c - lemma2 (case2 g) | case1 d = ¬d d - lemma2 (case2 g) | case2 r = ¬r r - - problem3 : (¬ Rabbit ) → Cat - problem3 ¬r with lem Cat | lem Goat - problem3 ¬r | case1 c | g = c - problem3 ¬r | case2 ¬c | g = ⊥-elim ( ¬r ( fact3 p lemma3 )) where - lemma3 : ¬ ( Cat ∨ Goat ) - lemma3 (case1 c) = ¬c c - lemma3 (case2 g) with fact2 p ¬c - lemma3 (case2 g) | case1 d = fact1 p (case2 d ) g - lemma3 (case2 g) | case2 r = ¬r r - -module pet-research1 ( Cat Dog Goat Rabbit : Set ) where - - open import Data.Bool - open import Relation.Binary - open import Relation.Binary.PropositionalEquality - - _=>_ : Bool → Bool → Bool - _ => true = true - false => _ = true - true => false = false - - ¬_ : Bool → Bool - ¬ p = not p - - problem0 : ( Cat Dog Goat Rabbit : Bool ) → - ((( Cat ∨ Dog ) => (¬ Goat) ) ∧ ( (¬ Cat ) => ( Dog ∨ Rabbit ) ) ∧ ( ( ¬ ( Cat ∨ Goat ) ) => Rabbit ) ) - => (Cat ∨ Dog ∨ Goat ∨ Rabbit) ≡ true - problem0 true d g r = refl - problem0 false true g r = refl - problem0 false false true r = refl - problem0 false false false true = refl - problem0 false false false false = refl - - problem1 : ( Cat Dog Goat Rabbit : Bool ) → - ((( Cat ∨ Dog ) => (¬ Goat) ) ∧ ( (¬ Cat ) => ( Dog ∨ Rabbit ) ) ∧ ( ( ¬ ( Cat ∨ Goat ) ) => Rabbit ) ) - => ( Goat => ( ¬ Dog )) ≡ true - problem1 c false false r = refl - problem1 c true false r = refl - problem1 c false true r = refl - problem1 false true true r = refl - problem1 true true true r = refl - - problem2 : ( Cat Dog Goat Rabbit : Bool ) → - ((( Cat ∨ Dog ) => (¬ Goat) ) ∧ ( (¬ Cat ) => ( Dog ∨ Rabbit ) ) ∧ ( ( ¬ ( Cat ∨ Goat ) ) => Rabbit ) ) - => ( Goat => Rabbit ) ≡ true - problem2 c d false false = refl - problem2 c d false true = refl - problem2 c d true true = refl - problem2 true d true false = refl - problem2 false false true false = refl - problem2 false true true false = refl - - problem3 : ( Cat Dog Goat Rabbit : Bool ) → - ((( Cat ∨ Dog ) => (¬ Goat) ) ∧ ( (¬ Cat ) => ( Dog ∨ Rabbit ) ) ∧ ( ( ¬ ( Cat ∨ Goat ) ) => Rabbit ) ) - => ( (¬ Rabbit ) => Cat ) ≡ true - problem3 false d g true = refl - problem3 true d g true = refl - problem3 true d g false = refl - problem3 false false false false = refl - problem3 false false true false = refl - problem3 false true false false = refl - problem3 false true true false = refl - --- module pet-research2 ( Cat Dog Goat Rabbit : Set ) where --- --- open import Data.Bool hiding ( _∨_ ) --- open import Relation.Binary --- open import Relation.Binary.PropositionalEquality --- --- ¬_ : Bool → Bool --- ¬ p = p xor true --- --- infixr 5 _∨_ --- _∨_ : Bool → Bool → Bool --- a ∨ b = ¬ ( (¬ a) ∧ (¬ b ) ) --- --- _=>_ : Bool → Bool → Bool --- a => b = (¬ a ) ∨ b --- --- open import Data.Bool.Solver using (module xor-∧-Solver) --- open xor-∧-Solver --- --- problem0' : ( Cat : Bool ) → (Cat xor Cat ) ≡ false --- problem0' = solve 1 (λ c → (c :+ c ) := con false ) refl --- --- problem1' : ( Cat : Bool ) → (Cat ∧ (Cat xor true )) ≡ false --- problem1' = solve 1 (λ c → ((c :* (c :+ con true )) ) := con false ) {!!} --- --- open import Data.Nat --- :¬_ : {n : ℕ} → Polynomial n → Polynomial n --- :¬ p = p :+ con true --- --- _:∨_ : {n : ℕ} → Polynomial n → Polynomial n → Polynomial n --- a :∨ b = :¬ ( ( :¬ a ) :* ( :¬ b )) --- --- _:=>_ : {n : ℕ} → Polynomial n → Polynomial n → Polynomial n --- a :=> b = ( :¬ a ) :∨ b --- --- _:∧_ = _:*_ --- --- infixr 6 _:∧_ --- infixr 5 _:∨_ --- --- problem0 : ( Cat Dog Goat Rabbit : Bool ) → --- ((( Cat ∨ Dog ) => (¬ Goat) ) ∧ ( (¬ Cat ) => ( Dog ∨ Rabbit ) ) ∧ ( ( ¬ ( Cat ∨ Goat ) ) => Rabbit ) ) --- => (Cat ∨ Dog ∨ Goat ∨ Rabbit) ≡ true --- problem0 = solve 4 ( λ Cat Dog Goat Rabbit → ( --- ( ((Cat :∨ Dog ) :=> (:¬ Goat)) :∧ ( ((:¬ Cat ) :=> ( Dog :∨ Rabbit )) :∧ (( :¬ ( Cat :∨ Goat ) ) :=> Rabbit) )) --- :=> ( Cat :∨ (Dog :∨ ( Goat :∨ Rabbit))) ) := con true ) {!!} --- --- problem1 : ( Cat Dog Goat Rabbit : Bool ) → --- ((( Cat ∨ Dog ) => (¬ Goat) ) ∧ ( (¬ Cat ) => ( Dog ∨ Rabbit ) ) ∧ ( ( ¬ ( Cat ∨ Goat ) ) => Rabbit ) ) --- => ( Goat => ( ¬ Dog )) ≡ true --- problem1 c false false r = {!!} --- problem1 c true false r = {!!} --- problem1 c false true r = {!!} --- problem1 false true true r = refl --- problem1 true true true r = refl --- --- problem2 : ( Cat Dog Goat Rabbit : Bool ) → --- ((( Cat ∨ Dog ) => (¬ Goat) ) ∧ ( (¬ Cat ) => ( Dog ∨ Rabbit ) ) ∧ ( ( ¬ ( Cat ∨ Goat ) ) => Rabbit ) ) --- => ( Goat => Rabbit ) ≡ true --- problem2 c d false false = {!!} --- problem2 c d false true = {!!} --- problem2 c d true true = {!!} --- problem2 true d true false = refl --- problem2 false false true false = refl --- problem2 false true true false = refl --- --- problem3 : ( Cat Dog Goat Rabbit : Bool ) → --- ((( Cat ∨ Dog ) => (¬ Goat) ) ∧ ( (¬ Cat ) => ( Dog ∨ Rabbit ) ) ∧ ( ( ¬ ( Cat ∨ Goat ) ) => Rabbit ) ) --- => ( (¬ Rabbit ) => Cat ) ≡ true --- problem3 false d g true = {!!} --- problem3 true d g true = {!!} --- problem3 true d g false = {!!} --- problem3 false false false false = refl --- problem3 false false true false = refl --- problem3 false true false false = refl --- problem3 false true true false = refl
--- a/automaton-in-agda/src/agda/regex.agda Sun Jun 13 18:48:57 2021 +0900 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,14 +0,0 @@ -module regex where - -data Regex ( Σ : Set) : Set where - ε : Regex Σ -- empty - φ : Regex Σ -- fail - _* : Regex Σ → Regex Σ - _&_ : Regex Σ → Regex Σ → Regex Σ - _||_ : Regex Σ → Regex Σ → Regex Σ - <_> : Σ → Regex Σ - -infixr 40 _&_ _||_ - - -
--- a/automaton-in-agda/src/agda/regex1.agda Sun Jun 13 18:48:57 2021 +0900 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,128 +0,0 @@ -{-# OPTIONS --allow-unsolved-metas #-} -module regex1 where - -open import Level renaming ( suc to succ ; zero to Zero ) -open import Data.Fin -open import Data.Nat hiding ( _≟_ ) -open import Data.List hiding ( any ; [_] ) -import Data.Bool using ( Bool ; true ; false ; _∧_ ) -open import Data.Bool using ( Bool ; true ; false ; _∧_ ; _∨_ ) -open import Relation.Binary.PropositionalEquality as RBF hiding ( [_] ) -open import Relation.Nullary using (¬_; Dec; yes; no) -open import regex - --- postulate a b c d : Set - -data In : Set where - a : In - b : In - c : In - d : In - -cmpi : (x y : In ) → Dec (x ≡ y) -cmpi a a = yes refl -cmpi b b = yes refl -cmpi c c = yes refl -cmpi d d = yes refl -cmpi a b = no (λ ()) -cmpi a c = no (λ ()) -cmpi a d = no (λ ()) -cmpi b a = no (λ ()) -cmpi b c = no (λ ()) -cmpi b d = no (λ ()) -cmpi c a = no (λ ()) -cmpi c b = no (λ ()) -cmpi c d = no (λ ()) -cmpi d a = no (λ ()) -cmpi d b = no (λ ()) -cmpi d c = no (λ ()) - --- infixr 40 _&_ _||_ - -r1' = (< a > & < b >) & < c > --- abc -r1 = < a > & < b > & < c > --- abc -any = < a > || < b > || < c > --- a|b|c -r2 = ( any * ) & ( < a > & < b > & < c > ) -- .*abc -r3 = ( any * ) & ( < a > & < b > & < c > & < a > & < b > & < c > ) -r4 = ( < a > & < b > & < c > ) || ( < b > & < c > & < d > ) -r5 = ( any * ) & ( < a > & < b > & < c > || < b > & < c > & < d > ) - -open import nfa - --- former ++ later ≡ x -split : {Σ : Set} → ((former : List Σ) → Bool) → ((later : List Σ) → Bool) → (x : List Σ ) → Bool -split x y [] = x [] ∧ y [] -split x y (h ∷ t) = (x [] ∧ y (h ∷ t)) ∨ - split (λ t1 → x ( h ∷ t1 )) (λ t2 → y t2 ) t - --- tt1 : {Σ : Set} → ( P Q : List In → Bool ) → split P Q ( a ∷ b ∷ c ∷ [] ) --- tt1 P Q = ? - -{-# TERMINATING #-} -repeat : {Σ : Set} → (List Σ → Bool) → List Σ → Bool -repeat x [] = true -repeat {Σ} x ( h ∷ t ) = split x (repeat {Σ} x) ( h ∷ t ) - -regular-language : {Σ : Set} → Regex Σ → ((x y : Σ ) → Dec (x ≡ y)) → List Σ → Bool -regular-language φ cmp _ = false -regular-language ε cmp [] = true -regular-language ε cmp (_ ∷ _) = false -regular-language (x *) cmp = repeat ( regular-language x cmp ) -regular-language (x & y) cmp = split ( λ z → (regular-language x cmp) z ) (λ z → regular-language y cmp z ) -regular-language (x || y) cmp = λ s → ( regular-language x cmp s ) ∨ ( regular-language y cmp s) -regular-language < h > cmp [] = false -regular-language < h > cmp (h1 ∷ [] ) with cmp h h1 -... | yes _ = true -... | no _ = false -regular-language < h > _ (_ ∷ _ ∷ _) = false - -test-regex : regular-language r1' cmpi ( a ∷ [] ) ≡ false -test-regex = refl - -test-regex1 : regular-language r2 cmpi ( a ∷ a ∷ b ∷ c ∷ [] ) ≡ true -test-regex1 = refl - - -test-AB→split : {Σ : Set} → {A B : List In → Bool} → split A B ( a ∷ b ∷ a ∷ [] ) ≡ ( - ( A [] ∧ B ( a ∷ b ∷ a ∷ [] ) ) ∨ - ( A ( a ∷ [] ) ∧ B ( b ∷ a ∷ [] ) ) ∨ - ( A ( a ∷ b ∷ [] ) ∧ B ( a ∷ [] ) ) ∨ - ( A ( a ∷ b ∷ a ∷ [] ) ∧ B [] ) - ) -test-AB→split {_} {A} {B} = refl - --- from example 1.53 1 - -ex53-1 : Set -ex53-1 = (s : List In ) → regular-language ( (< a > *) & < b > & (< a > *) ) cmpi s ≡ true → {!!} -- contains exact one b - -ex53-2 : Set -ex53-2 = (s : List In ) → regular-language ( (any * ) & < b > & (any *) ) cmpi s ≡ true → {!!} -- contains at lease one b - -evenp : {Σ : Set} → List Σ → Bool -oddp : {Σ : Set} → List Σ → Bool -oddp [] = false -oddp (_ ∷ t) = evenp t - -evenp [] = true -evenp (_ ∷ t) = oddp t - --- from example 1.53 5 -egex-even : Set -egex-even = (s : List In ) → regular-language ( ( any & any ) * ) cmpi s ≡ true → evenp s ≡ true - -test11 = regular-language ( ( any & any ) * ) cmpi (a ∷ []) -test12 = regular-language ( ( any & any ) * ) cmpi (a ∷ b ∷ []) - --- proof-egex-even : egex-even --- proof-egex-even [] _ = refl --- proof-egex-even (a ∷ []) () --- proof-egex-even (b ∷ []) () --- proof-egex-even (c ∷ []) () --- proof-egex-even (x ∷ x₁ ∷ s) y = proof-egex-even s {!!} - -open import derive In cmpi -open import automaton - -ra-ex = trace (regex→automaton r2) (record { state = r2 ; is-derived = unit }) ( a ∷ b ∷ c ∷ []) -
--- a/automaton-in-agda/src/agda/regular-concat.agda Sun Jun 13 18:48:57 2021 +0900 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,240 +0,0 @@ -module regular-concat where - -open import Level renaming ( suc to Suc ; zero to Zero ) -open import Data.List -open import Data.Nat hiding ( _≟_ ) -open import Data.Fin hiding ( _+_ ) -open import Data.Empty -open import Data.Unit -open import Data.Product --- open import Data.Maybe -open import Relation.Nullary -open import Relation.Binary.PropositionalEquality hiding ( [_] ) -open import logic -open import nat -open import automaton -open import regular-language - -open import nfa -open import sbconst2 - -open RegularLanguage -open Automaton - -Concat-NFA : {Σ : Set} → (A B : RegularLanguage Σ ) → ((x y : states A )→ Dec (x ≡ y)) → ((x y : states B )→ Dec (x ≡ y)) - → NAutomaton (states A ∨ states B) Σ -Concat-NFA {Σ} A B equal?A equal?B = record { Nδ = δnfa ; Nend = nend } - module Concat-NFA where - δnfa : states A ∨ states B → Σ → states A ∨ states B → Bool - δnfa (case1 q) i (case1 q₁) with equal?A (δ (automaton A) q i) q₁ - ... | yes _ = true - ... | no _ = false - δnfa (case1 qa) i (case2 qb) with equal?B qb (δ (automaton B) (astart B) i) - ... | yes _ = aend (automaton A) qa - ... | no _ = false - δnfa (case2 q) i (case2 q₁) with equal?B (δ (automaton B) q i) q₁ - ... | yes _ = true - ... | no _ = false - δnfa _ i _ = false - nend : states A ∨ states B → Bool - nend (case2 q) = aend (automaton B) q - nend (case1 q) = aend (automaton A) q /\ aend (automaton B) (astart B) -- empty B case - -Concat-NFA-start : {Σ : Set} → (A B : RegularLanguage Σ ) → states A ∨ states B → ((x y : states A )→ Dec (x ≡ y)) → Bool -Concat-NFA-start A B (case1 a) equal?A with equal?A a (astart A) -... | yes _ = true -... | no _ = false -Concat-NFA-start A B (case2 b) equal?A = false - -M-Concat : {Σ : Set} → (A B : RegularLanguage Σ ) → ((states A → Bool) → Bool) → ((states B → Bool) → Bool) → RegularLanguage Σ -M-Concat {Σ} A B existsA existsB = record { - states = states A ∨ states B → Bool - ; astart = λ ab → Concat-NFA-start A B ab {!!} - ; automaton = subset-construction sbexists (Concat-NFA A B {!!} {!!} ) - } where - sbexists : (states A ∨ states B → Bool) → Bool - sbexists P = existsA ( λ a → existsB ( λ b → P (case1 a) \/ P (case2 b))) - -record Split {Σ : Set} (A : List Σ → Bool ) ( B : List Σ → Bool ) (x : List Σ ) : Set where - field - sp0 : List Σ - sp1 : List Σ - sp-concat : sp0 ++ sp1 ≡ x - prop0 : A sp0 ≡ true - prop1 : B sp1 ≡ true - -open Split - -list-empty++ : {Σ : Set} → (x y : List Σ) → x ++ y ≡ [] → (x ≡ [] ) ∧ (y ≡ [] ) -list-empty++ [] [] refl = record { proj1 = refl ; proj2 = refl } -list-empty++ [] (x ∷ y) () -list-empty++ (x ∷ x₁) y () - -open _∧_ - -open import Relation.Binary.PropositionalEquality hiding ( [_] ) - -c-split-lemma : {Σ : Set} → (A B : List Σ → Bool ) → (h : Σ) → ( t : List Σ ) → split A B (h ∷ t ) ≡ true - → ( ¬ (A [] ≡ true )) ∨ ( ¬ (B ( h ∷ t ) ≡ true) ) - → split (λ t1 → A (h ∷ t1)) B t ≡ true -c-split-lemma {Σ} A B h t eq p = sym ( begin - true - ≡⟨ sym eq ⟩ - split A B (h ∷ t ) - ≡⟨⟩ - A [] /\ B (h ∷ t) \/ split (λ t1 → A (h ∷ t1)) B t - ≡⟨ cong ( λ k → k \/ split (λ t1 → A (h ∷ t1)) B t ) (lemma-p p ) ⟩ - false \/ split (λ t1 → A (h ∷ t1)) B t - ≡⟨ bool-or-1 refl ⟩ - split (λ t1 → A (h ∷ t1)) B t - ∎ ) where - open ≡-Reasoning - lemma-p : ( ¬ (A [] ≡ true )) ∨ ( ¬ (B ( h ∷ t ) ≡ true) ) → A [] /\ B (h ∷ t) ≡ false - lemma-p (case1 ¬A ) = bool-and-1 ( ¬-bool-t ¬A ) - lemma-p (case2 ¬B ) = bool-and-2 ( ¬-bool-t ¬B ) - -split→AB : {Σ : Set} → (A B : List Σ → Bool ) → ( x : List Σ ) → split A B x ≡ true → Split A B x -split→AB {Σ} A B [] eq with bool-≡-? (A []) true | bool-≡-? (B []) true -split→AB {Σ} A B [] eq | yes eqa | yes eqb = - record { sp0 = [] ; sp1 = [] ; sp-concat = refl ; prop0 = eqa ; prop1 = eqb } -split→AB {Σ} A B [] eq | yes p | no ¬p = ⊥-elim (lemma-∧-1 eq (¬-bool-t ¬p )) -split→AB {Σ} A B [] eq | no ¬p | t = ⊥-elim (lemma-∧-0 eq (¬-bool-t ¬p )) -split→AB {Σ} A B (h ∷ t ) eq with bool-≡-? (A []) true | bool-≡-? (B (h ∷ t )) true -... | yes px | yes py = record { sp0 = [] ; sp1 = h ∷ t ; sp-concat = refl ; prop0 = px ; prop1 = py } -... | no px | _ with split→AB (λ t1 → A ( h ∷ t1 )) B t (c-split-lemma A B h t eq (case1 px) ) -... | S = record { sp0 = h ∷ sp0 S ; sp1 = sp1 S ; sp-concat = cong ( λ k → h ∷ k) (sp-concat S) ; prop0 = prop0 S ; prop1 = prop1 S } -split→AB {Σ} A B (h ∷ t ) eq | _ | no px with split→AB (λ t1 → A ( h ∷ t1 )) B t (c-split-lemma A B h t eq (case2 px) ) -... | S = record { sp0 = h ∷ sp0 S ; sp1 = sp1 S ; sp-concat = cong ( λ k → h ∷ k) (sp-concat S) ; prop0 = prop0 S ; prop1 = prop1 S } - -AB→split : {Σ : Set} → (A B : List Σ → Bool ) → ( x y : List Σ ) → A x ≡ true → B y ≡ true → split A B (x ++ y ) ≡ true -AB→split {Σ} A B [] [] eqa eqb = begin - split A B [] - ≡⟨⟩ - A [] /\ B [] - ≡⟨ cong₂ (λ j k → j /\ k ) eqa eqb ⟩ - true - ∎ where open ≡-Reasoning -AB→split {Σ} A B [] (h ∷ y ) eqa eqb = begin - split A B (h ∷ y ) - ≡⟨⟩ - A [] /\ B (h ∷ y) \/ split (λ t1 → A (h ∷ t1)) B y - ≡⟨ cong₂ (λ j k → j /\ k \/ split (λ t1 → A (h ∷ t1)) B y ) eqa eqb ⟩ - true /\ true \/ split (λ t1 → A (h ∷ t1)) B y - ≡⟨⟩ - true \/ split (λ t1 → A (h ∷ t1)) B y - ≡⟨⟩ - true - ∎ where open ≡-Reasoning -AB→split {Σ} A B (h ∷ t) y eqa eqb = begin - split A B ((h ∷ t) ++ y) - ≡⟨⟩ - A [] /\ B (h ∷ t ++ y) \/ split (λ t1 → A (h ∷ t1)) B (t ++ y) - ≡⟨ cong ( λ k → A [] /\ B (h ∷ t ++ y) \/ k ) (AB→split {Σ} (λ t1 → A (h ∷ t1)) B t y eqa eqb ) ⟩ - A [] /\ B (h ∷ t ++ y) \/ true - ≡⟨ bool-or-3 ⟩ - true - ∎ where open ≡-Reasoning - -open NAutomaton -open import Data.List.Properties - -open import finiteSet -open import finiteSetUtil - -open FiniteSet - -closed-in-concat : {Σ : Set} → (A B : RegularLanguage Σ ) → ( x : List Σ ) → isRegular (Concat (contain A) (contain B)) x ( M-Concat A B ) -closed-in-concat {Σ} A B x = ≡-Bool-func closed-in-concat→ closed-in-concat← where - afin : (A : RegularLanguage Σ ) → FiniteSet A - afin = ? - finab = (fin-∨ (afin A) (afin B)) - NFA = (Concat-NFA A B) - abmove : (q : states A ∨ states B) → (h : Σ ) → states A ∨ states B - abmove (case1 q) h = case1 (δ (automaton A) q h) - abmove (case2 q) h = case2 (δ (automaton B) q h) - lemma-nmove-ab : (q : states A ∨ states B) → (h : Σ ) → Nδ NFA q h (abmove q h) ≡ true - lemma-nmove-ab (case1 q) _ = ? -- equal?-refl (afin A) - lemma-nmove-ab (case2 q) _ = ? -- equal?-refl (afin B) - nmove : (q : states A ∨ states B) (nq : states A ∨ states B → Bool ) → (nq q ≡ true) → ( h : Σ ) → - exists finab (λ qn → nq qn /\ Nδ NFA qn h (abmove q h)) ≡ true - nmove (case1 q) nq nqt h = found finab (case1 q) ( bool-and-tt nqt (lemma-nmove-ab (case1 q) h) ) - nmove (case2 q) nq nqt h = found finab (case2 q) ( bool-and-tt nqt (lemma-nmove-ab (case2 q) h) ) - acceptB : (z : List Σ) → (q : states B) → (nq : states A ∨ states B → Bool ) → (nq (case2 q) ≡ true) → ( accept (automaton B) q z ≡ true ) - → Naccept NFA finab nq z ≡ true - acceptB [] q nq nqt fb = lemma8 where - lemma8 : exists finab ( λ q → nq q /\ Nend NFA q ) ≡ true - lemma8 = found finab (case2 q) ( bool-and-tt nqt fb ) - acceptB (h ∷ t ) q nq nq=q fb = acceptB t (δ (automaton B) q h) (Nmoves NFA finab nq h) (nmove (case2 q) nq nq=q h) fb - - acceptA : (y z : List Σ) → (q : states A) → (nq : states A ∨ states B → Bool ) → (nq (case1 q) ≡ true) - → ( accept (automaton A) q y ≡ true ) → ( accept (automaton B) (astart B) z ≡ true ) - → Naccept NFA finab nq (y ++ z) ≡ true - acceptA [] [] q nq nqt fa fb = found finab (case1 q) (bool-and-tt nqt (bool-and-tt fa fb )) - acceptA [] (h ∷ z) q nq nq=q fa fb = acceptB z nextb (Nmoves NFA finab nq h) lemma70 fb where - nextb : states B - nextb = δ (automaton B) (astart B) h - lemma70 : exists finab (λ qn → nq qn /\ Nδ NFA qn h (case2 nextb)) ≡ true - lemma70 = found finab (case1 q) ( bool-and-tt nq=q (bool-and-tt fa (lemma-nmove-ab (case2 (astart B)) h) )) - acceptA (h ∷ t) z q nq nq=q fa fb = acceptA t z (δ (automaton A) q h) (Nmoves NFA finab nq h) (nmove (case1 q) nq nq=q h) fa fb where - - acceptAB : Split (contain A) (contain B) x - → Naccept NFA finab (equal? finab (case1 (astart A))) x ≡ true - acceptAB S = subst ( λ k → Naccept NFA finab (equal? finab (case1 (astart A))) k ≡ true ) ( sp-concat S ) - (acceptA (sp0 S) (sp1 S) (astart A) (equal? finab (case1 (astart A))) ? (prop0 S) (prop1 S) ) - - closed-in-concat→ : Concat (contain A) (contain B) x ≡ true → contain (M-Concat A B) x ≡ true - closed-in-concat→ concat with split→AB (contain A) (contain B) x concat - ... | S = begin - accept (subset-construction finab NFA (case1 (astart A))) (Concat-NFA-start A B ) x - ≡⟨ ≡-Bool-func (subset-construction-lemma← finab NFA (case1 (astart A)) x ) - (subset-construction-lemma→ finab NFA (case1 (astart A)) x ) ⟩ - Naccept NFA finab (equal? finab (case1 (astart A))) x - ≡⟨ acceptAB S ⟩ - true - ∎ where open ≡-Reasoning - - open Found - - ab-case : (q : states A ∨ states B ) → (qa : states A ) → (x : List Σ ) → Set - ab-case (case1 qa') qa x = qa' ≡ qa - ab-case (case2 qb) qa x = ¬ ( accept (automaton B) qb x ≡ true ) - - contain-A : (x : List Σ) → (nq : states A ∨ states B → Bool ) → (fn : Naccept NFA finab nq x ≡ true ) - → (qa : states A ) → ( (q : states A ∨ states B) → nq q ≡ true → ab-case q qa x ) - → split (accept (automaton A) qa ) (contain B) x ≡ true - contain-A [] nq fn qa cond with found← finab fn - ... | S with found-q S | inspect found-q S | cond (found-q S) (bool-∧→tt-0 (found-p S)) - ... | case1 qa' | record { eq = refl } | refl = bool-∧→tt-1 (found-p S) - ... | case2 qb | record { eq = refl } | ab = ⊥-elim ( ab (bool-∧→tt-1 (found-p S))) - contain-A (h ∷ t) nq fn qa cond with bool-≡-? ((aend (automaton A) qa) /\ accept (automaton B) (δ (automaton B) (astart B) h) t ) true - ... | yes eq = bool-or-41 eq - ... | no ne = bool-or-31 (contain-A t (Nmoves NFA finab nq h) fn (δ (automaton A) qa h) lemma11 ) where - lemma11 : (q : states A ∨ states B) → exists finab (λ qn → nq qn /\ Nδ NFA qn h q) ≡ true → ab-case q (δ (automaton A) qa h) t - lemma11 (case1 qa') ex with found← finab ex - ... | S with found-q S | inspect found-q S | cond (found-q S) (bool-∧→tt-0 (found-p S)) - ... | case1 qa | record { eq = refl } | refl = sym ( equal→refl (afin A) ( bool-∧→tt-1 (found-p S) )) -- continued A case - ... | case2 qb | record { eq = refl } | nb with bool-∧→tt-1 (found-p S) -- δnfa (case2 q) i (case1 q₁) is false - ... | () - lemma11 (case2 qb) ex with found← finab ex - ... | S with found-q S | inspect found-q S | cond (found-q S) (bool-∧→tt-0 (found-p S)) - lemma11 (case2 qb) ex | S | case2 qb' | record { eq = refl } | nb = contra-position lemma13 nb where -- continued B case should fail - lemma13 : accept (automaton B) qb t ≡ true → accept (automaton B) qb' (h ∷ t) ≡ true - lemma13 fb = subst (λ k → accept (automaton B) k t ≡ true ) (sym (equal→refl (afin B) (bool-∧→tt-1 (found-p S)))) fb - lemma11 (case2 qb) ex | S | case1 qa | record { eq = refl } | refl with bool-∧→tt-1 (found-p S) - ... | eee = contra-position lemma12 ne where -- starting B case should fail - lemma12 : accept (automaton B) qb t ≡ true → aend (automaton A) qa /\ accept (automaton B) (δ (automaton B) (astart B) h) t ≡ true - lemma12 fb = bool-and-tt (bool-∧→tt-0 eee) (subst ( λ k → accept (automaton B) k t ≡ true ) (equal→refl (afin B) (bool-∧→tt-1 eee) ) fb ) - - lemma10 : Naccept NFA finab (equal? finab (case1 (astart A))) x ≡ true → split (contain A) (contain B) x ≡ true - lemma10 CC = contain-A x (Concat-NFA-start A B ) CC (astart A) lemma15 where - lemma15 : (q : states A ∨ states B) → Concat-NFA-start A B q ≡ true → ab-case q (astart A) x - lemma15 q nq=t with equal→refl finab nq=t - ... | refl = refl - - closed-in-concat← : contain (M-Concat A B) x ≡ true → Concat (contain A) (contain B) x ≡ true - closed-in-concat← C with subset-construction-lemma← finab NFA (case1 (astart A)) x C - ... | CC = lemma10 CC - - - -
--- a/automaton-in-agda/src/agda/regular-language.agda Sun Jun 13 18:48:57 2021 +0900 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,87 +0,0 @@ -module regular-language where - -open import Level renaming ( suc to Suc ; zero to Zero ) -open import Data.List -open import Data.Nat hiding ( _≟_ ) -open import Data.Fin hiding ( _+_ ) -open import Data.Empty -open import Data.Unit -open import Data.Product --- open import Data.Maybe -open import Relation.Nullary -open import Relation.Binary.PropositionalEquality hiding ( [_] ) -open import logic -open import nat -open import automaton - -language : { Σ : Set } → Set -language {Σ} = List Σ → Bool - -language-L : { Σ : Set } → Set -language-L {Σ} = List (List Σ) - -open Automaton - -record RegularLanguage ( Σ : Set ) : Set (Suc Zero) where - field - states : Set - astart : states - automaton : Automaton states Σ - contain : List Σ → Bool - contain x = accept automaton astart x - -Union : {Σ : Set} → ( A B : language {Σ} ) → language {Σ} -Union {Σ} A B x = (A x ) \/ (B x) - -split : {Σ : Set} → (List Σ → Bool) - → ( List Σ → Bool) → List Σ → Bool -split x y [] = x [] /\ y [] -split x y (h ∷ t) = (x [] /\ y (h ∷ t)) \/ - split (λ t1 → x ( h ∷ t1 )) (λ t2 → y t2 ) t - -Concat : {Σ : Set} → ( A B : language {Σ} ) → language {Σ} -Concat {Σ} A B = split A B - -{-# TERMINATING #-} -Star : {Σ : Set} → ( A : language {Σ} ) → language {Σ} -Star {Σ} A = split A ( Star {Σ} A ) - -open import automaton-ex - -test-AB→split : {Σ : Set} → {A B : List In2 → Bool} → split A B ( i0 ∷ i1 ∷ i0 ∷ [] ) ≡ ( - ( A [] /\ B ( i0 ∷ i1 ∷ i0 ∷ [] ) ) \/ - ( A ( i0 ∷ [] ) /\ B ( i1 ∷ i0 ∷ [] ) ) \/ - ( A ( i0 ∷ i1 ∷ [] ) /\ B ( i0 ∷ [] ) ) \/ - ( A ( i0 ∷ i1 ∷ i0 ∷ [] ) /\ B [] ) - ) -test-AB→split {_} {A} {B} = refl - -open RegularLanguage -isRegular : {Σ : Set} → (A : language {Σ} ) → ( x : List Σ ) → (r : RegularLanguage Σ ) → Set -isRegular A x r = A x ≡ contain r x - --- postulate --- fin-× : {A B : Set} → { a b : ℕ } → FiniteSet A {a} → FiniteSet B {b} → FiniteSet (A × B) {a * b} - -M-Union : {Σ : Set} → (A B : RegularLanguage Σ ) → RegularLanguage Σ -M-Union {Σ} A B = record { - states = states A × states B - ; astart = ( astart A , astart B ) - ; automaton = record { - δ = λ q x → ( δ (automaton A) (proj₁ q) x , δ (automaton B) (proj₂ q) x ) - ; aend = λ q → ( aend (automaton A) (proj₁ q) \/ aend (automaton B) (proj₂ q) ) - } - } - -closed-in-union : {Σ : Set} → (A B : RegularLanguage Σ ) → ( x : List Σ ) → isRegular (Union (contain A) (contain B)) x ( M-Union A B ) -closed-in-union A B [] = lemma where - lemma : aend (automaton A) (astart A) \/ aend (automaton B) (astart B) ≡ - aend (automaton A) (astart A) \/ aend (automaton B) (astart B) - lemma = refl -closed-in-union {Σ} A B ( h ∷ t ) = lemma1 t ((δ (automaton A) (astart A) h)) ((δ (automaton B) (astart B) h)) where - lemma1 : (t : List Σ) → (qa : states A ) → (qb : states B ) → - accept (automaton A) qa t \/ accept (automaton B) qb t - ≡ accept (automaton (M-Union A B)) (qa , qb) t - lemma1 [] qa qb = refl - lemma1 (h ∷ t ) qa qb = lemma1 t ((δ (automaton A) qa h)) ((δ (automaton B) qb h)) -
--- a/automaton-in-agda/src/agda/root2.agda Sun Jun 13 18:48:57 2021 +0900 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,100 +0,0 @@ -module root2 where - -open import Data.Nat -open import Data.Nat.Properties -open import Data.Empty -open import Data.Unit using (⊤ ; tt) -open import Relation.Nullary -open import Relation.Binary.PropositionalEquality -open import Relation.Binary.Definitions - -open import gcd -open import even -open import nat - -record Rational : Set where - field - i j : ℕ - coprime : gcd i j ≡ 1 - -even→gcd=2 : {n : ℕ} → even n → n > 0 → gcd n 2 ≡ 2 -even→gcd=2 {suc (suc zero)} en (s≤s z≤n) = refl -even→gcd=2 {suc (suc (suc (suc n)))} en (s≤s z≤n) = begin - gcd (suc (suc (suc (suc n)))) 2 ≡⟨⟩ - gcd (suc (suc n)) 2 ≡⟨ even→gcd=2 {suc (suc n)} en (s≤s z≤n) ⟩ - 2 ∎ where open ≡-Reasoning - -even^2 : {n : ℕ} → even ( n * n ) → even n -even^2 {n} en with even? n -... | yes y = y -... | no ne = ⊥-elim ( odd4 ((2 * m) + 2 * m * suc (2 * m)) (n+even {2 * m} {2 * m * suc (2 * m)} ee3 ee4) (subst (λ k → even k) ee2 en )) where - m : ℕ - m = Odd.j ( odd3 n ne ) - ee3 : even (2 * m) - ee3 = subst (λ k → even k ) (*-comm m 2) (n*even {m} {2} tt ) - ee4 : even ((2 * m) * suc (2 * m)) - ee4 = even*n {(2 * m)} {suc (2 * m)} (even*n {2} {m} tt ) - ee2 : n * n ≡ suc (2 * m) + ((2 * m) * (suc (2 * m) )) - ee2 = begin n * n ≡⟨ cong ( λ k → k * k) (Odd.is-twice (odd3 n ne)) ⟩ - suc (2 * m) * suc (2 * m) ≡⟨ *-distribʳ-+ (suc (2 * m)) 1 ((2 * m) ) ⟩ - (1 * suc (2 * m)) + 2 * m * suc (2 * m) ≡⟨ cong (λ k → k + 2 * m * suc (2 * m)) (begin - suc m + 1 * m + 0 * (suc m + 1 * m ) ≡⟨ +-comm (suc m + 1 * m) 0 ⟩ - suc m + 1 * m ≡⟨⟩ - suc (2 * m) - ∎) ⟩ suc (2 * m) + 2 * m * suc (2 * m) ∎ where open ≡-Reasoning - -e3 : {i j : ℕ } → 2 * i ≡ 2 * j → i ≡ j -e3 {zero} {zero} refl = refl -e3 {suc x} {suc y} eq with <-cmp x y -... | tri< a ¬b ¬c = ⊥-elim ( nat-≡< eq (s≤s (<-trans (<-plus a) (<-plus-0 (s≤s (<-plus a )))))) -... | tri≈ ¬a b ¬c = cong suc b -... | tri> ¬a ¬b c = ⊥-elim ( nat-≡< (sym eq) (s≤s (<-trans (<-plus c) (<-plus-0 (s≤s (<-plus c )))))) - -open Factor - -root2-irrational : ( n m : ℕ ) → n > 1 → m > 1 → 2 * n * n ≡ m * m → ¬ (gcd n m ≡ 1) -root2-irrational n m n>1 m>1 2nm = rot13 ( gcd-gt n n m m 2 f2 f2 f2 fm {!!} {!!} {!!} {!!}) where - rot13 : {m : ℕ } → Dividable 2 m → m ≡ 1 → ⊥ - rot13 d refl with Dividable.is-factor d - ... | t = {!!} - rot11 : {m : ℕ } → even m → Factor 2 m - rot11 {zero} em = record { factor = 0 ; remain = 0 ; is-factor = refl } - rot11 {suc zero} () - rot11 {suc (suc m) } em = record { factor = suc (factor fc ) ; remain = remain fc ; is-factor = isfc } where - fc : Factor 2 m - fc = rot11 {m} em - isfc : suc (factor fc) * 2 + remain fc ≡ suc (suc m) - isfc = begin - suc (factor fc) * 2 + remain fc ≡⟨ cong (λ k → k + remain fc) (*-distribʳ-+ 2 1 (factor fc)) ⟩ - ((1 * 2) + (factor fc)* 2 ) + remain fc ≡⟨⟩ - ((1 + 1) + (factor fc)* 2 ) + remain fc ≡⟨ cong (λ k → k + remain fc) (+-assoc 1 1 _ ) ⟩ - (1 + (1 + (factor fc)* 2 )) + remain fc ≡⟨⟩ - suc (suc ((factor fc * 2) + remain fc )) ≡⟨ cong (λ x → suc (suc x)) (is-factor fc) ⟩ - suc (suc m) ∎ where open ≡-Reasoning - rot5 : {n : ℕ} → n > 1 → n > 0 - rot5 {n} lt = <-trans a<sa lt - rot1 : even ( m * m ) - rot1 = subst (λ k → even k ) rot4 (n*even {n * n} {2} tt ) where - rot4 : (n * n) * 2 ≡ m * m - rot4 = begin - (n * n) * 2 ≡⟨ *-comm (n * n) 2 ⟩ - 2 * ( n * n ) ≡⟨ sym (*-assoc 2 n n) ⟩ - 2 * n * n ≡⟨ 2nm ⟩ - m * m ∎ where open ≡-Reasoning - E : Even m - E = e2 m ( even^2 {m} ( rot1 )) - rot2 : 2 * n * n ≡ 2 * Even.j E * m - rot2 = subst (λ k → 2 * n * n ≡ k * m ) (Even.is-twice E) 2nm - rot3 : n * n ≡ Even.j E * m - rot3 = e3 ( begin - 2 * (n * n) ≡⟨ sym (*-assoc 2 n _) ⟩ - 2 * n * n ≡⟨ rot2 ⟩ - 2 * Even.j E * m ≡⟨ *-assoc 2 (Even.j E) m ⟩ - 2 * (Even.j E * m) ∎ ) where open ≡-Reasoning - rot7 : even n - rot7 = even^2 {n} (subst (λ k → even k) (sym rot3) ((n*even {Even.j E} {m} ( even^2 {m} ( rot1 ))))) - f2 : Factor 2 n - f2 = rot11 rot7 - fm : Factor 2 m - fm = record { factor = Even.j E ; remain = 0 ; is-factor = {!!} } -
--- a/automaton-in-agda/src/agda/sbconst2.agda Sun Jun 13 18:48:57 2021 +0900 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,55 +0,0 @@ -module sbconst2 where - -open import Level renaming ( suc to succ ; zero to Zero ) -open import Data.Nat -open import Data.Fin -open import Data.List - -open import automaton -open import nfa -open import logic -open NAutomaton -open Automaton -open import Relation.Binary.PropositionalEquality hiding ( [_] ) - -open Bool - -δconv : { Q : Set } { Σ : Set } → ( ( Q → Bool ) → Bool ) → ( nδ : Q → Σ → Q → Bool ) → (f : Q → Bool) → (i : Σ) → (Q → Bool) -δconv {Q} { Σ} exists nδ f i q = exists ( λ r → f r /\ nδ r i q ) - -subset-construction : { Q : Set } { Σ : Set } → - ( ( Q → Bool ) → Bool ) → - (NAutomaton Q Σ ) → (Automaton (Q → Bool) Σ ) -subset-construction {Q} { Σ} exists NFA = record { - δ = λ q x → δconv exists ( Nδ NFA ) q x - ; aend = λ f → exists ( λ q → f q /\ Nend NFA q ) - } - -test4 = subset-construction existsS1 am2 - -test51 = accept test4 start1 ( i0 ∷ i1 ∷ i0 ∷ [] ) -test61 = accept test4 start1 ( i1 ∷ i1 ∷ i1 ∷ [] ) - -subset-construction-lemma→ : { Q : Set } { Σ : Set } { n : ℕ } → (exists : ( Q → Bool ) → Bool ) → - (NFA : NAutomaton Q Σ ) → (astart : Q → Bool ) - → (x : List Σ) - → Naccept NFA exists astart x ≡ true - → accept ( subset-construction exists NFA ) astart x ≡ true -subset-construction-lemma→ {Q} {Σ} {n} exists NFA astart x naccept = lemma1 x astart naccept where - lemma1 : (x : List Σ) → ( states : Q → Bool ) - → Naccept NFA exists states x ≡ true - → accept ( subset-construction exists NFA ) states x ≡ true - lemma1 [] states naccept = naccept - lemma1 (h ∷ t ) states naccept = lemma1 t (δconv exists (Nδ NFA) states h) naccept - -subset-construction-lemma← : { Q : Set } { Σ : Set } { n : ℕ } → (exists : ( Q → Bool ) → Bool ) → - (NFA : NAutomaton Q Σ ) → (astart : Q → Bool ) - → (x : List Σ) - → accept ( subset-construction exists NFA ) astart x ≡ true - → Naccept NFA exists astart x ≡ true -subset-construction-lemma← {Q} {Σ} {n} exists NFA astart x saccept = lemma2 x astart saccept where - lemma2 : (x : List Σ) → ( states : Q → Bool ) - → accept ( subset-construction exists NFA ) states x ≡ true - → Naccept NFA exists states x ≡ true - lemma2 [] states saccept = saccept - lemma2 (h ∷ t ) states saccept = lemma2 t (δconv exists (Nδ NFA) states h) saccept
--- a/automaton-in-agda/src/agda/turing.agda Sun Jun 13 18:48:57 2021 +0900 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,129 +0,0 @@ -{-# OPTIONS --allow-unsolved-metas #-} -module turing where - -open import Level renaming ( suc to succ ; zero to Zero ) -open import Data.Nat -- hiding ( erase ) -open import Data.List -open import Data.Maybe hiding ( map ) -open import Data.Bool using ( Bool ; true ; false ) renaming ( not to negate ) -open import Relation.Binary.PropositionalEquality hiding ( [_] ) -open import Relation.Nullary using (¬_; Dec; yes; no) -open import Level renaming ( suc to succ ; zero to Zero ) -open import Data.Product hiding ( map ) - - -data Write ( Σ : Set ) : Set where - write : Σ → Write Σ - wnone : Write Σ - -- erase write tnone - -data Move : Set where - left : Move - right : Move - mnone : Move - --- at tδ both stack is poped - --- write S push S , push SR --- erase push SL , push tone --- none push SL , push SR --- left push SR , pop --- right pop , push SL - -{-# TERMINATING #-} -move : {Q Σ : Set } → { tnone : Σ} → {tδ : Q → Σ → Q × ( Write Σ ) × Move } → (q : Q ) ( L : List Σ ) ( L : List Σ ) → ( Q × List Σ × List Σ ) -move {Q} {Σ} {tnone} {tδ} q L [] = move {Q} {Σ} {tnone} {tδ} q L ( tnone ∷ [] ) -move {Q} {Σ} {tnone} {tδ} q [] R = move {Q} {Σ} {tnone} {tδ} q ( tnone ∷ [] ) R -move {Q} {Σ} {tnone} {tδ} q ( LH ∷ LT ) ( RH ∷ RT ) with tδ q LH -... | nq , write x , left = ( nq , ( RH ∷ x ∷ LT ) , RT ) -... | nq , write x , right = ( nq , LT , ( x ∷ RH ∷ RT ) ) -... | nq , write x , mnone = ( nq , ( x ∷ LT ) , ( RH ∷ RT ) ) -... | nq , wnone , left = ( nq , ( RH ∷ LH ∷ LT ) , RT ) -... | nq , wnone , right = ( nq , LT , ( LH ∷ RH ∷ RT ) ) -... | nq , wnone , mnone = ( nq , ( LH ∷ LT ) , ( RH ∷ RT ) ) -{-# TERMINATING #-} -move-loop : {Q Σ : Set } → {tend : Q → Bool} → { tnone : Σ} → {tδ : Q → Σ → Q × ( Write Σ ) × Move } - → (q : Q ) ( L : List Σ ) ( L : List Σ ) → ( Q × List Σ × List Σ ) -move-loop {Q} {Σ} {tend} {tnone} {tδ} q L R with tend q -... | true = ( q , L , R ) -... | flase = move-loop {Q} {Σ} {tend} {tnone} {tδ} ( proj₁ next ) ( proj₁ ( proj₂ next ) ) ( proj₂ ( proj₂ next ) ) - where - next = move {Q} {Σ} {tnone} {tδ} q L R - -{-# TERMINATING #-} -move0 : {Q Σ : Set } ( tend : Q → Bool ) (tnone : Σ ) (tδ : Q → Σ → Q × ( Write Σ ) × Move) - (q : Q ) ( L : List Σ ) ( L : List Σ ) → ( Q × List Σ × List Σ ) -move0 tend tnone tδ q L R with tend q -... | true = ( q , L , R ) -move0 tend tnone tδ q L [] | false = move0 tend tnone tδ q L ( tnone ∷ [] ) -move0 tend tnone tδ q [] R | false = move0 tend tnone tδ q ( tnone ∷ [] ) R -move0 tend tnone tδ q ( LH ∷ LT ) ( RH ∷ RT ) | false with tδ q LH -... | nq , write x , left = move0 tend tnone tδ nq ( RH ∷ x ∷ LT ) RT -... | nq , write x , right = move0 tend tnone tδ nq LT ( x ∷ RH ∷ RT ) -... | nq , write x , mnone = move0 tend tnone tδ nq ( x ∷ LT ) ( RH ∷ RT ) -... | nq , wnone , left = move0 tend tnone tδ nq ( RH ∷ LH ∷ LT ) RT -... | nq , wnone , right = move0 tend tnone tδ nq LT ( LH ∷ RH ∷ RT ) -... | nq , wnone , mnone = move0 tend tnone tδ nq ( LH ∷ LT ) ( RH ∷ RT ) - -record Turing ( Q : Set ) ( Σ : Set ) - : Set where - field - tδ : Q → Σ → Q × ( Write Σ ) × Move - tstart : Q - tend : Q → Bool - tnone : Σ - taccept : List Σ → ( Q × List Σ × List Σ ) - taccept L = move0 tend tnone tδ tstart L [] - -data CopyStates : Set where - s1 : CopyStates - s2 : CopyStates - s3 : CopyStates - s4 : CopyStates - s5 : CopyStates - H : CopyStates - - -Copyδ : CopyStates → ℕ → CopyStates × ( Write ℕ ) × Move -Copyδ s1 0 = H , wnone , mnone -Copyδ s1 1 = s2 , write 0 , right -Copyδ s2 0 = s3 , write 0 , right -Copyδ s2 1 = s2 , write 1 , right -Copyδ s3 0 = s4 , write 1 , left -Copyδ s3 1 = s3 , write 1 , right -Copyδ s4 0 = s5 , write 0 , left -Copyδ s4 1 = s4 , write 1 , left -Copyδ s5 0 = s1 , write 1 , right -Copyδ s5 1 = s5 , write 1 , left -Copyδ H _ = H , wnone , mnone -Copyδ _ (suc (suc _)) = H , wnone , mnone - -copyMachine : Turing CopyStates ℕ -copyMachine = record { - tδ = Copyδ - ; tstart = s1 - ; tend = tend - ; tnone = 0 - } where - tend : CopyStates → Bool - tend H = true - tend _ = false - -test1 : CopyStates × ( List ℕ ) × ( List ℕ ) -test1 = Turing.taccept copyMachine ( 1 ∷ 1 ∷ 0 ∷ 0 ∷ 0 ∷ [] ) - -test2 : ℕ → CopyStates × ( List ℕ ) × ( List ℕ ) -test2 n = loop n (Turing.tstart copyMachine) ( 1 ∷ 1 ∷ 0 ∷ 0 ∷ 0 ∷ [] ) [] - where - loop : ℕ → CopyStates → ( List ℕ ) → ( List ℕ ) → CopyStates × ( List ℕ ) × ( List ℕ ) - loop zero q L R = ( q , L , R ) - loop (suc n) q L R = loop n ( proj₁ t1 ) ( proj₁ ( proj₂ t1 ) ) ( proj₂ ( proj₂ t1 ) ) - where - t1 = move {CopyStates} {ℕ} {0} {Copyδ} q L R - --- testn = map (\ n -> test2 n) ( 0 ∷ 1 ∷ 2 ∷ 3 ∷ 4 ∷ 5 ∷ 6 ∷ [] ) - -testn : ℕ → List ( CopyStates × ( List ℕ ) × ( List ℕ ) ) -testn 0 = test2 0 ∷ [] -testn (suc n) = test2 n ∷ testn n -
--- a/automaton-in-agda/src/agda/utm.agda Sun Jun 13 18:48:57 2021 +0900 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,250 +0,0 @@ -module utm where - -open import turing -open import Data.Product -open import Data.Bool -open import Data.List -open import Data.Nat - -data utmStates : Set where - reads : utmStates - read0 : utmStates - read1 : utmStates - read2 : utmStates - read3 : utmStates - read4 : utmStates - read5 : utmStates - read6 : utmStates - - loc0 : utmStates - loc1 : utmStates - loc2 : utmStates - loc3 : utmStates - loc4 : utmStates - loc5 : utmStates - loc6 : utmStates - - fetch0 : utmStates - fetch1 : utmStates - fetch2 : utmStates - fetch3 : utmStates - fetch4 : utmStates - fetch5 : utmStates - fetch6 : utmStates - fetch7 : utmStates - - print0 : utmStates - print1 : utmStates - print2 : utmStates - print3 : utmStates - print4 : utmStates - print5 : utmStates - print6 : utmStates - print7 : utmStates - - mov0 : utmStates - mov1 : utmStates - mov2 : utmStates - mov3 : utmStates - mov4 : utmStates - mov5 : utmStates - mov6 : utmStates - - tidy0 : utmStates - tidy1 : utmStates - halt : utmStates - -data utmΣ : Set where - ０ : utmΣ - １ : utmΣ - B : utmΣ - * : utmΣ - $ : utmΣ - ^ : utmΣ - X : utmΣ - Y : utmΣ - Z : utmΣ - ＠ : utmΣ - b : utmΣ - -utmδ : utmStates → utmΣ → utmStates × (Write utmΣ) × Move -utmδ reads x = read0 , wnone , mnone -utmδ read0 * = read1 , write * , left -utmδ read0 x = read0 , write x , right -utmδ read1 x = read2 , write ＠ , right -utmδ read2 ^ = read3 , write ^ , right -utmδ read2 x = read2 , write x , right -utmδ read3 ０ = read4 , write ０ , left -utmδ read3 １ = read5 , write １ , left -utmδ read3 b = read6 , write b , left -utmδ read4 ＠ = loc0 , write ０ , right -utmδ read4 x = read4 , write x , left -utmδ read5 ＠ = loc0 , write １ , right -utmδ read5 x = read5 , write x , left -utmδ read6 ＠ = loc0 , write B , right -utmδ read6 x = read6 , write x , left -utmδ loc0 ０ = loc0 , write X , left -utmδ loc0 １ = loc0 , write Y , left -utmδ loc0 B = loc0 , write Z , left -utmδ loc0 $ = loc1 , write $ , right -utmδ loc0 x = loc0 , write x , left -utmδ loc1 X = loc2 , write ０ , right -utmδ loc1 Y = loc3 , write １ , right -utmδ loc1 Z = loc4 , write B , right -utmδ loc1 * = fetch0 , write * , right -utmδ loc1 x = loc1 , write x , right -utmδ loc2 ０ = loc5 , write X , right -utmδ loc2 １ = loc6 , write Y , right -utmδ loc2 B = loc6 , write Z , right -utmδ loc2 x = loc2 , write x , right -utmδ loc3 １ = loc5 , write Y , right -utmδ loc3 ０ = loc6 , write X , right -utmδ loc3 B = loc6 , write Z , right -utmδ loc3 x = loc3 , write x , right -utmδ loc4 B = loc5 , write Z , right -utmδ loc4 ０ = loc6 , write X , right -utmδ loc4 １ = loc6 , write Y , right -utmδ loc4 x = loc4 , write x , right -utmδ loc5 $ = loc1 , write $ , right -utmδ loc5 x = loc5 , write x , left -utmδ loc6 $ = halt , write $ , right -utmδ loc6 * = loc0 , write * , left -utmδ loc6 x = loc6 , write x , right -utmδ fetch0 ０ = fetch1 , write X , left -utmδ fetch0 １ = fetch2 , write Y , left -utmδ fetch0 B = fetch3 , write Z , left -utmδ fetch0 x = fetch0 , write x , right -utmδ fetch1 $ = fetch4 , write $ , right -utmδ fetch1 x = fetch1 , write x , left -utmδ fetch2 $ = fetch5 , write $ , right -utmδ fetch2 x = fetch2 , write x , left -utmδ fetch3 $ = fetch6 , write $ , right -utmδ fetch3 x = fetch3 , write x , left -utmδ fetch4 ０ = fetch7 , write X , right -utmδ fetch4 １ = fetch7 , write X , right -utmδ fetch4 B = fetch7 , write X , right -utmδ fetch4 * = print0 , write * , left -utmδ fetch4 x = fetch4 , write x , right -utmδ fetch5 ０ = fetch7 , write Y , right -utmδ fetch5 １ = fetch7 , write Y , right -utmδ fetch5 B = fetch7 , write Y , right -utmδ fetch5 * = print0 , write * , left -utmδ fetch5 x = fetch5 , write x , right -utmδ fetch6 ０ = fetch7 , write Z , right -utmδ fetch6 １ = fetch7 , write Z , right -utmδ fetch6 B = fetch7 , write Z , right -utmδ fetch6 * = print0 , write * , left -utmδ fetch6 x = fetch6 , write x , right -utmδ fetch7 * = fetch0 , write * , right -utmδ fetch7 x = fetch7 , write x , right -utmδ print0 X = print1 , write X , right -utmδ print0 Y = print2 , write Y , right -utmδ print0 Z = print3 , write Z , right -utmδ print1 ^ = print4 , write ^ , right -utmδ print1 x = print1 , write x , right -utmδ print2 ^ = print5 , write ^ , right -utmδ print2 x = print2 , write x , right -utmδ print3 ^ = print6 , write ^ , right -utmδ print3 x = print3 , write x , right -utmδ print4 x = print7 , write ０ , left -utmδ print5 x = print7 , write １ , left -utmδ print6 x = print7 , write B , left -utmδ print7 X = mov0 , write X , right -utmδ print7 Y = mov1 , write Y , right -utmδ print7 x = print7 , write x , left -utmδ mov0 ^ = mov2 , write ^ , left -utmδ mov0 x = mov0 , write x , right -utmδ mov1 ^ = mov3 , write ^ , right -utmδ mov1 x = mov1 , write x , right -utmδ mov2 ０ = mov4 , write ^ , right -utmδ mov2 １ = mov5 , write ^ , right -utmδ mov2 B = mov6 , write ^ , right -utmδ mov3 ０ = mov4 , write ^ , left -utmδ mov3 １ = mov5 , write ^ , left -utmδ mov3 B = mov6 , write ^ , left -utmδ mov4 ^ = tidy0 , write ０ , left -utmδ mov5 ^ = tidy0 , write １ , left -utmδ mov6 ^ = tidy0 , write B , left -utmδ tidy0 $ = tidy1 , write $ , left -utmδ tidy0 x = tidy0 , write x , left -utmδ tidy1 X = tidy1 , write ０ , left -utmδ tidy1 Y = tidy1 , write １ , left -utmδ tidy1 Z = tidy1 , write B , left -utmδ tidy1 $ = reads , write $ , right -utmδ tidy1 x = tidy1 , write x , left -utmδ _ x = halt , write x , mnone - -U-TM : Turing utmStates utmΣ -U-TM = record { - tδ = utmδ - ; tstart = read0 - ; tend = tend - ; tnone = b - } where - tend : utmStates → Bool - tend halt = true - tend _ = false - --- Copyδ : CopyStates → ℕ → CopyStates × ( Write ℕ ) × Move --- Copyδ s1 0 = H , wnone , mnone --- Copyδ s1 1 = s2 , write 0 , right --- Copyδ s2 0 = s3 , write 0 , right --- Copyδ s2 1 = s2 , write 1 , right --- Copyδ s3 0 = s4 , write 1 , left --- Copyδ s3 1 = s3 , write 1 , right --- Copyδ s4 0 = s5 , write 0 , left --- Copyδ s4 1 = s4 , write 1 , left --- Copyδ s5 0 = s1 , write 1 , right --- Copyδ s5 1 = s5 , write 1 , left --- Copyδ H _ = H , wnone , mnone --- Copyδ _ (suc (suc _)) = H , wnone , mnone - -Copyδ-encode : List utmΣ -Copyδ-encode = - ０ ∷ ０ ∷ １ ∷ ０ ∷ １ ∷ １ ∷ ０ ∷ ０ ∷ ０ ∷ ０ ∷ -- s1 0 = H , wnone , mnone - * ∷ ０ ∷ ０ ∷ １ ∷ １ ∷ ０ ∷ １ ∷ ０ ∷ ０ ∷ ０ ∷ １ ∷ -- s1 1 = s2 , write 0 , right - * ∷ ０ ∷ １ ∷ ０ ∷ ０ ∷ ０ ∷ １ ∷ １ ∷ ０ ∷ ０ ∷ １ ∷ -- s2 0 = s3 , write 0 , right - * ∷ ０ ∷ １ ∷ ０ ∷ １ ∷ ０ ∷ １ ∷ ０ ∷ １ ∷ ０ ∷ １ ∷ -- s2 1 = s2 , write 1 , right - * ∷ ０ ∷ １ ∷ １ ∷ ０ ∷ １ ∷ ０ ∷ ０ ∷ １ ∷ ０ ∷ ０ ∷ -- s3 0 = s4 , write 1 , left - * ∷ ０ ∷ １ ∷ １ ∷ １ ∷ ０ ∷ １ ∷ １ ∷ １ ∷ ０ ∷ １ ∷ -- s3 1 = s3 , write 1 , right - * ∷ １ ∷ ０ ∷ ０ ∷ ０ ∷ １ ∷ ０ ∷ １ ∷ ０ ∷ ０ ∷ ０ ∷ -- s4 0 = s5 , write 0 , left - * ∷ １ ∷ ０ ∷ ０ ∷ １ ∷ １ ∷ ０ ∷ ０ ∷ １ ∷ ０ ∷ ０ ∷ -- s4 1 = s4 , write 1 , left - * ∷ １ ∷ ０ ∷ １ ∷ ０ ∷ ０ ∷ ０ ∷ １ ∷ １ ∷ ０ ∷ １ ∷ -- s5 0 = s1 , write 1 , right - * ∷ １ ∷ ０ ∷ １ ∷ １ ∷ １ ∷ ０ ∷ １ ∷ １ ∷ ０ ∷ ０ ∷ -- s5 1 = s5 , write 1 , left - [] - - -input-encode : List utmΣ -input-encode = １ ∷ １ ∷ ０ ∷ ０ ∷ ０ ∷ [] - -input+Copyδ : List utmΣ -input+Copyδ = ( $ ∷ ０ ∷ ０ ∷ ０ ∷ ０ ∷ * ∷ [] ) -- start state - ++ Copyδ-encode - ++ ( $ ∷ ^ ∷ input-encode ) - -short-input : List utmΣ -short-input = $ ∷ ０ ∷ ０ ∷ ０ ∷ * ∷ - ０ ∷ ０ ∷ ０ ∷ １ ∷ ０ ∷ １ ∷ １ ∷ * ∷ - ０ ∷ ０ ∷ １ ∷ ０ ∷ １ ∷ １ ∷ １ ∷ * ∷ - ０ ∷ １ ∷ B ∷ １ ∷ ０ ∷ １ ∷ ０ ∷ * ∷ - １ ∷ ０ ∷ ０ ∷ ０ ∷ １ ∷ １ ∷ １ ∷ $ ∷ - ^ ∷ ０ ∷ ０ ∷ １ ∷ １ ∷ [] - -utm-test1 : List utmΣ → utmStates × ( List utmΣ ) × ( List utmΣ ) -utm-test1 inp = Turing.taccept U-TM inp - -{-# TERMINATING #-} -utm-test2 : ℕ → List utmΣ → utmStates × ( List utmΣ ) × ( List utmΣ ) -utm-test2 n inp = loop n (Turing.tstart U-TM) inp [] - where - loop : ℕ → utmStates → ( List utmΣ ) → ( List utmΣ ) → utmStates × ( List utmΣ ) × ( List utmΣ ) - loop zero q L R = ( q , L , R ) - loop (suc n) q L R with move {utmStates} {utmΣ} {０} {utmδ} q L R | q - ... | nq , nL , nR | reads = loop n nq nL nR - ... | nq , nL , nR | _ = loop (suc n) nq nL nR - -t1 = utm-test2 20 short-input - -t : (n : ℕ) → utmStates × ( List utmΣ ) × ( List utmΣ ) --- t n = utm-test2 n input+Copyδ -t n = utm-test2 n short-input
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/automaton-in-agda/src/automaton-ex.agda Sun Jun 13 20:45:17 2021 +0900 @@ -0,0 +1,76 @@ +module automaton-ex where + +open import Data.Nat +open import Data.List +open import Data.Maybe +open import Relation.Binary.PropositionalEquality hiding ( [_] ) +open import Relation.Nullary using (¬_; Dec; yes; no) +open import logic + +open import automaton +open Automaton + +data StatesQ : Set where + q1 : StatesQ + q2 : StatesQ + q3 : StatesQ + +data In2 : Set where + i0 : In2 + i1 : In2 +transitionQ : StatesQ → In2 → StatesQ +transitionQ q1 i0 = q1 +transitionQ q1 i1 = q2 +transitionQ q2 i0 = q3 +transitionQ q2 i1 = q2 +transitionQ q3 i0 = q2 +transitionQ q3 i1 = q2 + +aendQ : StatesQ → Bool +aendQ q2 = true +aendQ _ = false + +a1 : Automaton StatesQ In2 +a1 = record { + δ = transitionQ + ; aend = aendQ + } + +test1 : accept a1 q1 ( i0 ∷ i1 ∷ i0 ∷ [] ) ≡ false +test1 = refl +test2 = accept a1 q1 ( i0 ∷ i1 ∷ i0 ∷ i1 ∷ [] ) + +data States1 : Set where + sr : States1 + ss : States1 + st : States1 + +transition1 : States1 → In2 → States1 +transition1 sr i0 = sr +transition1 sr i1 = ss +transition1 ss i0 = sr +transition1 ss i1 = st +transition1 st i0 = sr +transition1 st i1 = st + +fin1 : States1 → Bool +fin1 st = true +fin1 ss = false +fin1 sr = false + +am1 : Automaton States1 In2 +am1 = record { δ = transition1 ; aend = fin1 } + + +example1-1 = accept am1 sr ( i0 ∷ i1 ∷ i0 ∷ [] ) +example1-2 = accept am1 sr ( i1 ∷ i1 ∷ i1 ∷ [] ) +trace-2 = trace am1 sr ( i1 ∷ i1 ∷ i1 ∷ [] ) + +example1-3 = reachable am1 sr st ( i1 ∷ i1 ∷ i1 ∷ [] ) + +ieq : (i i' : In2 ) → Dec ( i ≡ i' ) +ieq i0 i0 = yes refl +ieq i1 i1 = yes refl +ieq i0 i1 = no ( λ () ) +ieq i1 i0 = no ( λ () ) +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/automaton-in-agda/src/automaton.agda Sun Jun 13 20:45:17 2021 +0900 @@ -0,0 +1,40 @@ +module automaton where + +open import Data.Nat +open import Data.List +open import Relation.Binary.PropositionalEquality hiding ( [_] ) +open import logic + +record Automaton ( Q : Set ) ( Σ : Set ) + : Set where + field + δ : Q → Σ → Q + aend : Q → Bool + +open Automaton + +accept : { Q : Set } { Σ : Set } + → Automaton Q Σ + → (astart : Q) + → List Σ → Bool +accept {Q} { Σ} M q [] = aend M q +accept {Q} { Σ} M q ( H ∷ T ) = accept M ( (δ M) q H ) T + +moves : { Q : Set } { Σ : Set } + → Automaton Q Σ + → Q → List Σ → Q +moves {Q} { Σ} M q [] = q +moves {Q} { Σ} M q ( H ∷ T ) = moves M ( δ M q H) T + +trace : { Q : Set } { Σ : Set } + → Automaton Q Σ + → Q → List Σ → List Q +trace {Q} { Σ} M q [] = q ∷ [] +trace {Q} { Σ} M q ( H ∷ T ) = q ∷ trace M ( (δ M) q H ) T + +reachable : { Q : Set } { Σ : Set } + → (M : Automaton Q Σ ) + → (astart q : Q ) + → (L : List Σ ) → Set +reachable M astart q L = moves M astart L ≡ q +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/automaton-in-agda/src/bijection.agda Sun Jun 13 20:45:17 2021 +0900 @@ -0,0 +1,180 @@ +module bijection where + +open import Level renaming ( zero to Zero ; suc to Suc ) +open import Data.Nat +open import Data.Maybe +open import Data.List hiding ([_]) +open import Data.Nat.Properties +open import Relation.Nullary +open import Data.Empty +open import Data.Unit +open import Relation.Binary.Core hiding (_⇔_) +open import Relation.Binary.Definitions +open import Relation.Binary.PropositionalEquality + +open import logic + +record Bijection {n m : Level} (R : Set n) (S : Set m) : Set (n Level.⊔ m) where + field + fun← : S → R + fun→ : R → S + fiso← : (x : R) → fun← ( fun→ x ) ≡ x + fiso→ : (x : S ) → fun→ ( fun← x ) ≡ x + +injection : {n m : Level} (R : Set n) (S : Set m) (f : R → S ) → Set (n Level.⊔ m) +injection R S f = (x y : R) → f x ≡ f y → x ≡ y + +open Bijection + +b→injection0 : {n m : Level} (R : Set n) (S : Set m) → (b : Bijection R S) → injection R S (fun→ b) +b→injection0 R S b x y eq = begin + x + ≡⟨ sym ( fiso← b x ) ⟩ + fun← b ( fun→ b x ) + ≡⟨ cong (λ k → fun← b k ) eq ⟩ + fun← b ( fun→ b y ) + ≡⟨ fiso← b y ⟩ + y + ∎ where open ≡-Reasoning + +b→injection1 : {n m : Level} (R : Set n) (S : Set m) → (b : Bijection R S) → injection S R (fun← b) +b→injection1 R S b x y eq = trans ( sym ( fiso→ b x ) ) (trans ( cong (λ k → fun→ b k ) eq ) ( fiso→ b y )) + +-- ¬ A = A → ⊥ + +diag : {S : Set } (b : Bijection ( S → Bool ) S) → S → Bool +diag b n = not (fun← b n n) + +diagonal : { S : Set } → ¬ Bijection ( S → Bool ) S +diagonal {S} b = diagn1 (fun→ b (diag b) ) refl where + diagn1 : (n : S ) → ¬ (fun→ b (diag b) ≡ n ) + diagn1 n dn = ¬t=f (diag b n ) ( begin + not (diag b n) + ≡⟨⟩ + not (not fun← b n n) + ≡⟨ cong (λ k → not (k n) ) (sym (fiso← b _)) ⟩ + not (fun← b (fun→ b (diag b)) n) + ≡⟨ cong (λ k → not (fun← b k n) ) dn ⟩ + not (fun← b n n) + ≡⟨⟩ + diag b n + ∎ ) where open ≡-Reasoning + +b1 : (b : Bijection ( ℕ → Bool ) ℕ) → ℕ +b1 b = fun→ b (diag b) + +b-iso : (b : Bijection ( ℕ → Bool ) ℕ) → fun← b (b1 b) ≡ (diag b) +b-iso b = fiso← b _ + +to1 : {n : Level} {R : Set n} → Bijection ℕ R → Bijection ℕ (⊤ ∨ R ) +to1 {n} {R} b = record { + fun← = to11 + ; fun→ = to12 + ; fiso← = to13 + ; fiso→ = to14 + } where + to11 : ⊤ ∨ R → ℕ + to11 (case1 tt) = 0 + to11 (case2 x) = suc ( fun← b x ) + to12 : ℕ → ⊤ ∨ R + to12 zero = case1 tt + to12 (suc n) = case2 ( fun→ b n) + to13 : (x : ℕ) → to11 (to12 x) ≡ x + to13 zero = refl + to13 (suc x) = cong suc (fiso← b x) + to14 : (x : ⊤ ∨ R) → to12 (to11 x) ≡ x + to14 (case1 x) = refl + to14 (case2 x) = cong case2 (fiso→ b x) + +open _∧_ + +open import nat + +open ≡-Reasoning + +-- [] 0 +-- 0 → 1 +-- 1 → 2 +-- 01 → 3 +-- 11 → 4 +-- ... +-- +{-# TERMINATING #-} +LBℕ : Bijection ℕ ( List Bool ) +LBℕ = record { + fun← = λ x → lton x + ; fun→ = λ n → ntol n + ; fiso← = lbiso0 + ; fiso→ = lbisor + } where + lton1 : List Bool → ℕ + lton1 [] = 0 + lton1 (true ∷ t) = suc (lton1 t + lton1 t) + lton1 (false ∷ t) = lton1 t + lton1 t + lton : List Bool → ℕ + lton [] = 0 + lton x = suc (lton1 x) + ntol1 : ℕ → List Bool + ntol1 0 = [] + ntol1 (suc x) with div2 (suc x) + ... | ⟪ x1 , true ⟫ = true ∷ ntol1 x1 -- non terminating + ... | ⟪ x1 , false ⟫ = false ∷ ntol1 x1 + ntol : ℕ → List Bool + ntol 0 = [] + ntol 1 = false ∷ [] + ntol (suc n) = ntol1 n + xx : (x : ℕ ) → List Bool ∧ ℕ + xx x = ⟪ (ntol x) , lton ((ntol x)) ⟫ + add11 : (x1 : ℕ ) → suc x1 + suc x1 ≡ suc (suc (x1 + x1)) + add11 zero = refl + add11 (suc x) = cong (λ k → suc (suc k)) (trans (+-comm x _) (cong suc (+-comm _ x))) + add12 : (x1 x : ℕ ) → suc x1 + x ≡ x1 + suc x + add12 zero x = refl + add12 (suc x1) x = cong suc (add12 x1 x) + ---- div2-eq : (x : ℕ ) → div2-rev ( div2 x ) ≡ x + div20 : (x x1 : ℕ ) → div2 (suc x) ≡ ⟪ x1 , false ⟫ → x1 + x1 ≡ suc x + div20 x x1 eq = begin + x1 + x1 ≡⟨ cong (λ k → div2-rev k ) (sym eq) ⟩ + div2-rev (div2 (suc x)) ≡⟨ div2-eq _ ⟩ + suc x ∎ + div21 : (x x1 : ℕ ) → div2 (suc x) ≡ ⟪ x1 , true ⟫ → suc (x1 + x1) ≡ suc x + div21 x x1 eq = begin + suc (x1 + x1) ≡⟨ cong (λ k → div2-rev k ) (sym eq) ⟩ + div2-rev (div2 (suc x)) ≡⟨ div2-eq _ ⟩ + suc x ∎ + lbiso1 : (x : ℕ) → suc (lton1 (ntol1 x)) ≡ suc x + lbiso1 zero = refl + lbiso1 (suc x) with div2 (suc x) | inspect div2 (suc x) + ... | ⟪ x1 , true ⟫ | record { eq = eq1 } = begin + suc (suc (lton1 (ntol1 x1) + lton1 (ntol1 x1))) ≡⟨ sym (add11 _) ⟩ + suc (lton1 (ntol1 x1)) + suc (lton1 (ntol1 x1)) ≡⟨ cong ( λ k → k + k ) (lbiso1 x1) ⟩ + suc x1 + suc x1 ≡⟨ add11 x1 ⟩ + suc (suc (x1 + x1)) ≡⟨ cong suc (div21 x x1 eq1) ⟩ + suc (suc x) ∎ + ... | ⟪ x1 , false ⟫ | record { eq = eq1 } = begin + suc (lton1 (ntol1 x1) + lton1 (ntol1 x1)) ≡⟨ cong ( λ k → k + lton1 (ntol1 x1) ) (lbiso1 x1) ⟩ + suc x1 + lton1 (ntol1 x1) ≡⟨ add12 _ _ ⟩ + x1 + suc (lton1 (ntol1 x1)) ≡⟨ cong ( λ k → x1 + k ) (lbiso1 x1) ⟩ + x1 + suc x1 ≡⟨ +-comm x1 _ ⟩ + suc (x1 + x1) ≡⟨ cong suc (div20 x x1 eq1) ⟩ + suc (suc x) ∎ + lbiso0 : (x : ℕ) → lton (ntol x) ≡ x + lbiso0 zero = refl + lbiso0 (suc zero) = refl + lbiso0 (suc (suc x)) = subst (λ k → k ≡ suc (suc x)) (hh x) ( lbiso1 (suc x)) where + hh : (x : ℕ ) → suc (lton1 (ntol1 (suc x))) ≡ lton (ntol (suc (suc x))) + hh x with div2 (suc x) + ... | ⟪ _ , true ⟫ = refl + ... | ⟪ _ , false ⟫ = refl + lbisor0 : (x : List Bool) → ntol1 (lton1 (true ∷ x)) ≡ true ∷ x + lbisor0 = {!!} + lbisor1 : (x : List Bool) → ntol1 (lton1 (false ∷ x)) ≡ false ∷ x + lbisor1 = {!!} + lbisor : (x : List Bool) → ntol (lton x) ≡ x + lbisor [] = refl + lbisor (false ∷ []) = refl + lbisor (true ∷ []) = refl + lbisor (false ∷ t) = trans {!!} ( lbisor1 t ) + lbisor (true ∷ t) = trans {!!} ( lbisor0 t ) + +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/automaton-in-agda/src/cfg.agda Sun Jun 13 20:45:17 2021 +0900 @@ -0,0 +1,134 @@ +module cfg where + +open import Level renaming ( suc to succ ; zero to Zero ) +open import Data.Nat hiding ( _≟_ ) +open import Data.Fin +open import Data.Product +open import Data.List +open import Data.Maybe +open import Data.Bool using ( Bool ; true ; false ; _∧_ ; _∨_ ) +open import Relation.Binary.PropositionalEquality hiding ( [_] ) +open import Relation.Nullary using (¬_; Dec; yes; no) +-- open import Data.String + +open import nfa + +data IsTerm (Token : Set) : Set where + isTerm : Token → IsTerm Token + noTerm : IsTerm Token + +record CFGGrammer (Token Node : Set) : Set (succ Zero) where + field + cfg : Node → List ( List ( Node ) ) + cfgtop : Node + term? : Node → IsTerm Token + tokensz : ℕ + tokenid : Token → Fin tokensz + +open CFGGrammer + +----------------- +-- +-- CGF language +-- +----------------- + +split : {Σ : Set} → (List Σ → Bool) + → ( List Σ → Bool) → List Σ → Bool +split x y [] = x [] ∧ y [] +split x y (h ∷ t) = (x [] ∧ y (h ∷ t)) ∨ + split (λ t1 → x ( h ∷ t1 )) (λ t2 → y t2 ) t + + +cfg-language0 : {Node Token : Set} → CFGGrammer Token Node → List (List Node ) → List Token → Bool + +{-# TERMINATING #-} +cfg-language2 : {Node Token : Set} → CFGGrammer Token Node → Node → List Token → Bool +cfg-language2 cg _ [] = false +cfg-language2 cg x (h1 ∷ [] ) with term? cg x +cfg-language2 cg x (h1 ∷ []) | isTerm t with tokenid cg h1 ≟ tokenid cg t +cfg-language2 cg x (h1 ∷ []) | isTerm t | yes p = true +cfg-language2 cg x (h1 ∷ []) | isTerm t | no ¬p = false +cfg-language2 cg x (h1 ∷ []) | noTerm = cfg-language0 cg (cfg cg x) ( h1 ∷ [] ) +cfg-language2 cg x In with term? cg x +cfg-language2 cg x In | isTerm t = false +cfg-language2 cg x In | noTerm = cfg-language0 cg (cfg cg x ) In + +cfg-language1 : {Node Token : Set} → CFGGrammer Token Node → List Node → List Token → Bool +cfg-language1 cg [] [] = true +cfg-language1 cg [] _ = false +cfg-language1 cg (node ∷ T) = split ( cfg-language2 cg node ) ( cfg-language1 cg T ) + +cfg-language0 cg [] [] = true +cfg-language0 cg [] _ = false +cfg-language0 cg (node ∷ T) In = cfg-language1 cg node In ∨ cfg-language0 cg T In + +cfg-language : {Node Token : Set} → CFGGrammer Token Node → List Token → Bool +cfg-language cg = cfg-language0 cg (cfg cg (cfgtop cg)) + +----------------- + +data IFToken : Set where + t:EA : IFToken + t:EB : IFToken + t:EC : IFToken + t:IF : IFToken + t:THEN : IFToken + t:ELSE : IFToken + t:SA : IFToken + t:SB : IFToken + t:SC : IFToken + +IFtokenid : IFToken → Fin 9 +IFtokenid t:EA = # 0 +IFtokenid t:EB = # 1 +IFtokenid t:EC = # 2 +IFtokenid t:IF = # 3 +IFtokenid t:THEN = # 4 +IFtokenid t:ELSE = # 5 +IFtokenid t:SA = # 6 +IFtokenid t:SB = # 7 +IFtokenid t:SC = # 8 + +data IFNode (T : Set) : Set where + Token : T → IFNode T + expr : IFNode T + statement : IFNode T + +IFGrammer : CFGGrammer IFToken (IFNode IFToken) +IFGrammer = record { + cfg = cfg' + ; cfgtop = statement + ; term? = term?' + ; tokensz = 9 + ; tokenid = IFtokenid + } where + term?' : IFNode IFToken → IsTerm IFToken + term?' (Token x) = isTerm x + term?' _ = noTerm + cfg' : IFNode IFToken → List ( List (IFNode IFToken) ) + cfg' (Token t) = ( (Token t) ∷ [] ) ∷ [] + cfg' expr = ( Token t:EA ∷ [] ) ∷ + ( Token t:EB ∷ [] ) ∷ + ( Token t:EC ∷ [] ) ∷ [] + cfg' statement = ( Token t:SA ∷ [] ) ∷ + ( Token t:SB ∷ [] ) ∷ + ( Token t:SC ∷ [] ) ∷ + ( Token t:IF ∷ expr ∷ statement ∷ [] ) ∷ + ( Token t:IF ∷ expr ∷ statement ∷ Token t:ELSE ∷ statement ∷ [] ) ∷ [] + + +cfgtest1 = cfg-language IFGrammer ( t:SA ∷ [] ) + +cfgtest2 = cfg-language2 IFGrammer (Token t:SA) ( t:SA ∷ [] ) + +cfgtest3 = cfg-language1 IFGrammer (Token t:SA ∷ [] ) ( t:SA ∷ [] ) + +cfgtest4 = cfg-language IFGrammer (t:IF ∷ t:EA ∷ t:SA ∷ [] ) + +cfgtest5 = cfg-language1 IFGrammer (Token t:IF ∷ expr ∷ statement ∷ []) (t:IF ∷ t:EA ∷ t:EA ∷ [] ) +cfgtest6 = cfg-language2 IFGrammer statement (t:IF ∷ t:EA ∷ t:SA ∷ [] ) +cfgtest7 = cfg-language1 IFGrammer (Token t:IF ∷ expr ∷ statement ∷ Token t:ELSE ∷ statement ∷ []) (t:IF ∷ t:EA ∷ t:SA ∷ t:ELSE ∷ t:SB ∷ [] ) + +cfgtest8 = cfg-language IFGrammer (t:IF ∷ t:EA ∷ t:IF ∷ t:EB ∷ t:SA ∷ t:ELSE ∷ t:SB ∷ [] ) +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/automaton-in-agda/src/cfg1.agda Sun Jun 13 20:45:17 2021 +0900 @@ -0,0 +1,184 @@ +module cfg1 where + +open import Level renaming ( suc to succ ; zero to Zero ) +open import Data.Nat hiding ( _≟_ ) +open import Data.Fin +open import Data.Product +open import Data.List +open import Data.Maybe +open import Data.Bool using ( Bool ; true ; false ; _∧_ ; _∨_ ) +open import Relation.Binary.PropositionalEquality hiding ( [_] ) +open import Relation.Nullary using (¬_; Dec; yes; no) + +-- +-- Java → Java Byte Code +-- +-- CFG Stack Machine (PDA) +-- + + +data Node (Symbol : Set) : Set where + T : Symbol → Node Symbol + N : Symbol → Node Symbol + +data Seq (Symbol : Set) : Set where + _，_ : Symbol → Seq Symbol → Seq Symbol + _． : Symbol → Seq Symbol + Error : Seq Symbol + +data Body (Symbol : Set) : Set where + _｜_ : Seq Symbol → Body Symbol → Body Symbol + _； : Seq Symbol → Body Symbol + +record CFGGrammer (Symbol : Set) : Set where + field + cfg : Symbol → Body Symbol + top : Symbol + eq? : Symbol → Symbol → Bool + typeof : Symbol → Node Symbol + +infixr 80 _｜_ +infixr 90 _； +infixr 100 _，_ +infixr 110 _． + +open CFGGrammer + +----------------- +-- +-- CGF language +-- +----------------- + +split : {Σ : Set} → (List Σ → Bool) + → ( List Σ → Bool) → List Σ → Bool +split x y [] = x [] ∧ y [] +split x y (h ∷ t) = (x [] ∧ y (h ∷ t)) ∨ + split (λ t1 → x ( h ∷ t1 )) (λ t2 → y t2 ) t + + +cfg-language0 : {Symbol : Set} → CFGGrammer Symbol → Body Symbol → List Symbol → Bool + +{-# TERMINATING #-} +cfg-language1 : {Symbol : Set} → CFGGrammer Symbol → Seq Symbol → List Symbol → Bool +cfg-language1 cg Error x = false +cfg-language1 cg (S ， seq) x with typeof cg S +cfg-language1 cg (_ ， seq) (x' ∷ t) | T x = eq? cg x x' ∧ cfg-language1 cg seq t +cfg-language1 cg (_ ， seq) [] | T x = false +cfg-language1 cg (_ ， seq) x | N nonTerminal = split (cfg-language0 cg (cfg cg nonTerminal) )(cfg-language1 cg seq ) x +cfg-language1 cg (S ．) x with typeof cg S +cfg-language1 cg (_ ．) (x' ∷ []) | T x = eq? cg x x' +cfg-language1 cg (_ ．) _ | T x = false +cfg-language1 cg (_ ．) x | N nonTerminal = cfg-language0 cg (cfg cg nonTerminal) x + +cfg-language0 cg _ [] = false +cfg-language0 cg (rule ｜ b) x = + cfg-language1 cg rule x ∨ cfg-language0 cg b x +cfg-language0 cg (rule ；) x = cfg-language1 cg rule x + +cfg-language : {Symbol : Set} → CFGGrammer Symbol → List Symbol → Bool +cfg-language cg = cfg-language0 cg (cfg cg (top cg )) + + +data IFToken : Set where + EA : IFToken + EB : IFToken + EC : IFToken + IF : IFToken + THEN : IFToken + ELSE : IFToken + SA : IFToken + SB : IFToken + SC : IFToken + expr : IFToken + statement : IFToken + +token-eq? : IFToken → IFToken → Bool +token-eq? EA EA = true +token-eq? EB EB = true +token-eq? EC EC = true +token-eq? IF IF = true +token-eq? THEN THEN = true +token-eq? ELSE ELSE = true +token-eq? SA SA = true +token-eq? SB SB = true +token-eq? SC SC = true +token-eq? expr expr = true +token-eq? statement statement = true +token-eq? _ _ = false + +typeof-IFG : IFToken → Node IFToken +typeof-IFG expr = N expr +typeof-IFG statement = N statement +typeof-IFG x = T x + +IFGrammer : CFGGrammer IFToken +IFGrammer = record { + cfg = cfg' + ; top = statement + ; eq? = token-eq? + ; typeof = typeof-IFG + } where + cfg' : IFToken → Body IFToken + cfg' expr = EA ． ｜ EB ． ｜ EC ． ； + cfg' statement = + SA ． ｜ SB ． ｜ SC ． + ｜ IF ， expr ， THEN ， statement ． + ｜ IF ， expr ， THEN ， statement ， ELSE ， statement ． + ； + cfg' x = Error ； + +cfgtest1 = cfg-language IFGrammer ( SA ∷ [] ) + +cfgtest2 = cfg-language1 IFGrammer ( SA ．) ( SA ∷ [] ) + +cfgtest3 = cfg-language1 IFGrammer ( SA ． ) ( SA ∷ [] ) + +cfgtest4 = cfg-language IFGrammer (IF ∷ EA ∷ THEN ∷ SA ∷ [] ) + +cfgtest5 = cfg-language1 IFGrammer ( IF ， expr ， THEN ， statement ． ) (IF ∷ EA ∷ THEN ∷ SA ∷ [] ) +cfgtest6 = cfg-language1 IFGrammer ( statement ．)(IF ∷ EA ∷ SA ∷ [] ) +cfgtest7 = cfg-language1 IFGrammer ( IF ， expr ， THEN ， statement ， ELSE ， statement ． ) + (IF ∷ EA ∷ THEN ∷ SA ∷ ELSE ∷ SB ∷ [] ) +cfgtest8 = cfg-language IFGrammer (IF ∷ EA ∷ THEN ∷ IF ∷ EB ∷ THEN ∷ SA ∷ ELSE ∷ SB ∷ [] ) +cfgtest9 = cfg-language IFGrammer (IF ∷ EB ∷ THEN ∷ SA ∷ ELSE ∷ SB ∷ [] ) + +data E1Token : Set where + e1 : E1Token + e[ : E1Token + e] : E1Token + expr : E1Token + term : E1Token + +E1-token-eq? : E1Token → E1Token → Bool +E1-token-eq? e1 e1 = true +E1-token-eq? e[ e] = true +E1-token-eq? e] e] = true +E1-token-eq? expr expr = true +E1-token-eq? term term = true +E1-token-eq? _ _ = false + +typeof-E1 : E1Token → Node E1Token +typeof-E1 expr = N expr +typeof-E1 term = N term +typeof-E1 x = T x + +E1Grammer : CFGGrammer E1Token +E1Grammer = record { + cfg = cfgE + ; top = expr + ; eq? = E1-token-eq? + ; typeof = typeof-E1 + } where + cfgE : E1Token → Body E1Token + cfgE expr = term ． + ； + cfgE term = e1 ． + ｜ e[ ， expr ， e] ． + ； + cfgE x = Error ； + +ecfgtest1 = cfg-language E1Grammer ( e1 ∷ [] ) +ecfgtest2 = cfg-language E1Grammer ( e[ ∷ e1 ∷ e] ∷ [] ) +ecfgtest3 = cfg-language E1Grammer ( e[ ∷ e[ ∷ e1 ∷ e] ∷ e] ∷ [] ) +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/automaton-in-agda/src/chap0.agda Sun Jun 13 20:45:17 2021 +0900 @@ -0,0 +1,210 @@ +module chap0 where + +open import Data.List +open import Data.Nat hiding (_⊔_) +-- open import Data.Integer hiding (_⊔_ ; _≟_ ; _+_ ) +open import Data.Product + +A : List ℕ +A = 1 ∷ 2 ∷ [] + +data Literal : Set where + x : Literal + y : Literal + z : Literal + +B : List Literal +B = x ∷ y ∷ z ∷ [] + + +ListProduct : {A B : Set } → List A → List B → List ( A × B ) +ListProduct = {!!} + +ex05 : List ( ℕ × Literal ) +ex05 = ListProduct A B -- (1 , x) ∷ (1 , y) ∷ (1 , z) ∷ (2 , x) ∷ (2 , y) ∷ (2 , z) ∷ [] + +ex06 : List ( ℕ × Literal × ℕ ) +ex06 = ListProduct A (ListProduct B A) + +ex07 : Set +ex07 = ℕ × ℕ + +data ex08-f : ℕ → ℕ → Set where + ex08f0 : ex08-f 0 1 + ex08f1 : ex08-f 1 2 + ex08f2 : ex08-f 2 3 + ex08f3 : ex08-f 3 4 + ex08f4 : ex08-f 4 0 + +data ex09-g : ℕ → ℕ → ℕ → ℕ → Set where + ex09g0 : ex09-g 0 1 2 3 + ex09g1 : ex09-g 1 2 3 0 + ex09g2 : ex09-g 2 3 0 1 + ex09g3 : ex09-g 3 0 1 2 + +open import Data.Nat.DivMod +open import Relation.Binary.PropositionalEquality +open import Relation.Binary.Core +open import Data.Nat.Properties + +-- _%_ : ℕ → ℕ → ℕ +-- _%_ a b with <-cmp a b +-- _%_ a b | tri< a₁ ¬b ¬c = a +-- _%_ a b | tri≈ ¬a b₁ ¬c = 0 +-- _%_ a b | tri> ¬a ¬b c = _%_ (a - b) b + +_≡7_ : ℕ → ℕ → Set +n ≡7 m = (n % 7) ≡ (m % 7 ) + +refl7 : { n : ℕ} → n ≡7 n +refl7 = {!!} + +sym7 : { n m : ℕ} → n ≡7 m → m ≡7 n +sym7 = {!!} + +trans7 : { n m o : ℕ} → n ≡7 m → m ≡7 o → n ≡7 o +trans7 = {!!} + +open import Level renaming ( zero to Zero ; suc to Suc ) + +record Graph { v v' : Level } : Set (Suc v ⊔ Suc v' ) where + field + vertex : Set v + edge : vertex → vertex → Set v' + +open Graph + +-- open import Data.Fin hiding ( _≟_ ) +open import Data.Empty +open import Relation.Nullary +open import Data.Unit hiding ( _≟_ ) + + +-- data Dec (P : Set) : Set where +-- yes : P → Dec P +-- no : ¬ P → Dec P +-- +-- _≟_ : (s t : ℕ ) → Dec ( s ≡ t ) + +-- ¬ A = A → ⊥ + +_n≟_ : (s t : ℕ ) → Dec ( s ≡ t ) +zero n≟ zero = yes refl +zero n≟ suc t = no (λ ()) +suc s n≟ zero = no (λ ()) +suc s n≟ suc t with s n≟ t +... | yes refl = yes refl +... | no n = no (λ k → n (tt1 k) ) where + tt1 : suc s ≡ suc t → s ≡ t + tt1 refl = refl + +open import Data.Bool hiding ( _≟_ ) + +conn : List ( ℕ × ℕ ) → ℕ → ℕ → Bool +conn [] _ _ = false +conn ((n1 , m1 ) ∷ t ) n m with n ≟ n1 | m ≟ m1 +conn ((n1 , m1) ∷ t) n m | yes refl | yes refl = true +conn ((n1 , m1) ∷ t) n m | _ | _ = conn t n m + +list012a : List ( ℕ × ℕ ) +list012a = (1 , 2) ∷ (2 , 3) ∷ (3 , 4) ∷ (4 , 5) ∷ (5 , 1) ∷ [] + +graph012a : Graph {Zero} {Zero} +graph012a = record { vertex = ℕ ; edge = λ s t → (conn list012a s t) ≡ true } + +data edge012b : ℕ → ℕ → Set where + e012b-1 : edge012b 1 2 + e012b-2 : edge012b 1 3 + e012b-3 : edge012b 1 4 + e012b-4 : edge012b 2 3 + e012b-5 : edge012b 2 4 + e012b-6 : edge012b 3 4 + +edge? : (E : ℕ → ℕ → Set) → ( a b : ℕ ) → Set +edge? E a b = Dec ( E a b ) + +lemma3 : ( a b : ℕ ) → edge? edge012b a b +lemma3 1 2 = yes e012b-1 +lemma3 1 3 = yes e012b-2 +lemma3 1 4 = yes e012b-3 +lemma3 2 3 = yes e012b-4 +lemma3 2 4 = yes e012b-5 +lemma3 3 4 = yes e012b-6 +lemma3 1 1 = no ( λ () ) +lemma3 2 1 = no ( λ () ) +lemma3 2 2 = no ( λ () ) +lemma3 3 1 = no ( λ () ) +lemma3 3 2 = no ( λ () ) +lemma3 3 3 = no ( λ () ) +lemma3 0 _ = no ( λ () ) +lemma3 _ 0 = no ( λ () ) +lemma3 _ (suc (suc (suc (suc (suc _))))) = no ( λ () ) +lemma3 (suc (suc (suc (suc _)))) _ = no ( λ () ) + +graph012b : Graph {Zero} {Zero} +graph012b = record { vertex = ℕ ; edge = edge012b } + +data connected { V : Set } ( E : V -> V -> Set ) ( x y : V ) : Set where + direct : E x y → connected E x y + indirect : ( z : V ) -> E x z → connected {V} E z y → connected E x y + +lemma1 : connected ( edge graph012a ) 1 2 +lemma1 = direct refl where + +lemma1-2 : connected ( edge graph012a ) 1 3 +lemma1-2 = indirect 2 refl (direct refl ) + +lemma2 : connected ( edge graph012b ) 1 2 +lemma2 = direct e012b-1 + +reachable : { V : Set } ( E : V -> V -> Set ) ( x y : V ) -> Set +reachable {V} E X Y = Dec ( connected {V} E X Y ) + +dag : { V : Set } ( E : V -> V -> Set ) -> Set +dag {V} E = ∀ (n : V) → ¬ ( connected E n n ) + +open import Function + +lemma4 : ¬ ( dag ( edge graph012a) ) +lemma4 neg = neg 1 $ indirect 2 refl $ indirect 3 refl $ indirect 4 refl $ indirect 5 refl $ direct refl + +dgree : List ( ℕ × ℕ ) → ℕ → ℕ +dgree [] _ = 0 +dgree ((e , e1) ∷ t) e0 with e0 ≟ e | e0 ≟ e1 +dgree ((e , e1) ∷ t) e0 | yes _ | _ = 1 + (dgree t e0) +dgree ((e , e1) ∷ t) e0 | _ | yes p = 1 + (dgree t e0) +dgree ((e , e1) ∷ t) e0 | no _ | no _ = dgree t e0 + +dgree-c : {t : Set} → List ( ℕ × ℕ ) → ℕ → (ℕ → t) → t +dgree-c {t} [] e0 next = next 0 +dgree-c {t} ((e , e1) ∷ tail ) e0 next with e0 ≟ e | e0 ≟ e1 +... | yes _ | _ = dgree-c tail e0 ( λ n → next (n + 1 )) +... | _ | yes _ = dgree-c tail e0 ( λ n → next (n + 1 )) +... | no _ | no _ = dgree-c tail e0 next + +lemma6 = dgree list012a 2 +lemma7 = dgree-c list012a 2 ( λ n → n ) + +even2 : (n : ℕ ) → n % 2 ≡ 0 → (n + 2) % 2 ≡ 0 +even2 0 refl = refl +even2 1 () +even2 (suc (suc n)) eq = trans ([a+n]%n≡a%n n _) eq -- [a+n]%n≡a%n : ∀ a n → (a + suc n) % suc n ≡ a % suc n + +sum-of-dgree : ( g : List ( ℕ × ℕ )) → ℕ +sum-of-dgree [] = 0 +sum-of-dgree ((e , e1) ∷ t) = 2 + sum-of-dgree t + +dgree-even : ( g : List ( ℕ × ℕ )) → sum-of-dgree g % 2 ≡ 0 +dgree-even [] = refl +dgree-even ((e , e1) ∷ t) = begin + sum-of-dgree ((e , e1) ∷ t) % 2 + ≡⟨⟩ + (2 + sum-of-dgree t ) % 2 + ≡⟨ cong ( λ k → k % 2 ) ( +-comm 2 (sum-of-dgree t) ) ⟩ + (sum-of-dgree t + 2) % 2 + ≡⟨ [a+n]%n≡a%n (sum-of-dgree t) _ ⟩ + sum-of-dgree t % 2 + ≡⟨ dgree-even t ⟩ + 0 + ∎ where open ≡-Reasoning +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/automaton-in-agda/src/derive.agda Sun Jun 13 20:45:17 2021 +0900 @@ -0,0 +1,126 @@ +{-# OPTIONS --allow-unsolved-metas #-} + +open import Relation.Binary.PropositionalEquality hiding ( [_] ) +open import Relation.Nullary using (¬_; Dec; yes; no) +open import Data.List hiding ( [_] ) + +module derive ( Σ : Set) ( eq? : (x y : Σ) → Dec (x ≡ y)) where + +-- open import nfa +open import Data.Nat +-- open import Data.Nat hiding ( _<_ ; _>_ ) +-- open import Data.Fin hiding ( _<_ ) + +open import finiteSet +open import FSetUtil +open import automaton +open import logic +open import regex + +empty? : Regex Σ → Bool +empty? ε = true +empty? φ = false +empty? (x *) = true +empty? (x & y) = empty? x /\ empty? y +empty? (x || y) = empty? x \/ empty? y +empty? < x > = false + +derivative0 : Regex Σ → Σ → Regex Σ +derivative0 ε s = φ +derivative0 φ s = φ +derivative0 (x *) s = derivative0 x s & (x *) +derivative0 (x & y) s with empty? x +... | true = (derivative0 x s & y) || derivative0 y s +... | false = derivative0 x s & y +derivative0 (x || y) s = derivative0 x s || derivative0 y s +derivative0 < x > s with eq? x s +... | yes _ = ε +... | no _ = φ + +derivative : Regex Σ → Σ → Regex Σ +derivative ε s = φ +derivative φ s = φ +derivative (x *) s with derivative x s +... | ε = x * +... | φ = φ +... | t = t & (x *) +derivative (x & y) s with empty? x +... | true with derivative x s | derivative y s +... | ε | φ = φ +... | ε | t = y || t +... | φ | t = t +... | x1 | φ = x1 & y +... | x1 | y1 = (x1 & y) || y1 +derivative (x & y) s | false with derivative x s +... | ε = y +... | φ = φ +... | t = t & y +derivative (x || y) s with derivative x s | derivative y s +... | φ | y1 = y1 +... | x1 | φ = x1 +... | x1 | y1 = x1 || y1 +derivative < x > s with eq? x s +... | yes _ = ε +... | no _ = φ + +data regex-states (x : Regex Σ ) : Regex Σ → Set where + unit : regex-states x x + derive : { y : Regex Σ } → regex-states x y → (s : Σ) → regex-states x ( derivative y s ) + +record Derivative (x : Regex Σ ) : Set where + field + state : Regex Σ + is-derived : regex-states x state + +open Derivative + +open import Data.Fin + +-- derivative generates (x & y) || ... form. y and x part is a substerm of original regex +-- since subterm is finite, only finite number of state is negerated, if we normalize ||-list. + +data subterm (r : Regex Σ) : Regex Σ → Set where + sε : subterm r ε + sφ : subterm r φ + orig : subterm r r + x& : {x y : Regex Σ } → subterm r (x & y) → subterm r x + &y : {x y : Regex Σ } → subterm r (x & y) → subterm r y + x| : {x y : Regex Σ } → subterm r (x || y) → subterm r x + |y : {x y : Regex Σ } → subterm r (x || y) → subterm r y + s* : {x : Regex Σ } → subterm r (x *) → subterm r x + s<_> : (s : Σ) → subterm r < s > → subterm r < s > + +record Subterm (r : Regex Σ) : Set where + field + subt : Regex Σ + is-subt : subterm r subt + +finsub : (r : Regex Σ ) → FiniteSet (Subterm r) +finsub ε = {!!} +finsub φ = {!!} +finsub (r *) = {!!} +finsub (r & r₁) = {!!} +finsub (r || r₁) = {!!} +finsub < x > = {!!} + +finsubList : (r : Regex Σ ) → FiniteSet (Subterm r ∧ Subterm r → Bool ) +finsubList r = fin→ ( fin-∧ (finsub r) (finsub r) ) + +-- derivative is subset of Subterm r → Subterm r → Bool + +der2ssb : {r : Regex Σ } → Derivative r → Subterm r ∧ Subterm r → Bool +der2ssb = {!!} + +-- we cannot say this, because Derivative is redundant +-- der2inject : {r : Regex Σ } → (x y : Derivative r ) → ( ( s t : Subterm r ∧ Subterm r ) → der2ssb x s ≡ der2ssb y t ) → x ≡ y + +-- this does not work, becuase it depends on input sequences +-- finite-derivative : (r : Regex Σ) → FiniteSet Σ → FiniteSet (Derivative r) + +-- in case of automaton, number of derivative is limited by iteration of input length, so it is finite. + +regex→automaton : (r : Regex Σ) → Automaton (Derivative r) Σ +regex→automaton r = record { δ = λ d s → record { state = derivative (state d) s ; is-derived = derive-step d s} ; aend = λ d → empty? (state d) } where + derive-step : (d0 : Derivative r) → (s : Σ) → regex-states r (derivative (state d0) s) + derive-step d0 s = derive (is-derived d0) s +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/automaton-in-agda/src/even.agda Sun Jun 13 20:45:17 2021 +0900 @@ -0,0 +1,71 @@ +module even where + +open import Data.Nat +open import Data.Nat.Properties +open import Data.Empty +open import Data.Unit using (⊤ ; tt) +open import Relation.Nullary +open import Relation.Binary.PropositionalEquality +open import Relation.Binary.Definitions +open import nat +open import logic + +even : (n : ℕ ) → Set +even zero = ⊤ +even (suc zero) = ⊥ +even (suc (suc n)) = even n + +even? : (n : ℕ ) → Dec ( even n ) +even? zero = yes tt +even? (suc zero) = no (λ ()) +even? (suc (suc n)) = even? n + +n+even : {n m : ℕ } → even n → even m → even ( n + m ) +n+even {zero} {zero} tt tt = tt +n+even {zero} {suc m} tt em = em +n+even {suc (suc n)} {m} en em = n+even {n} {m} en em + +n*even : {m n : ℕ } → even n → even ( m * n ) +n*even {zero} {n} en = tt +n*even {suc m} {n} en = n+even {n} {m * n} en (n*even {m} {n} en) + +even*n : {n m : ℕ } → even n → even ( n * m ) +even*n {n} {m} en = subst even (*-comm m n) (n*even {m} {n} en) + + +record Even (i : ℕ) : Set where + field + j : ℕ + is-twice : i ≡ 2 * j + +e2 : (i : ℕ) → even i → Even i +e2 zero en = record { j = 0 ; is-twice = refl } +e2 (suc (suc i)) en = record { j = suc (Even.j (e2 i en )) ; is-twice = e21 } where + e21 : suc (suc i) ≡ 2 * suc (Even.j (e2 i en)) + e21 = begin + suc (suc i) ≡⟨ cong (λ k → suc (suc k)) (Even.is-twice (e2 i en)) ⟩ + suc (suc (2 * Even.j (e2 i en))) ≡⟨ sym (*-distribˡ-+ 2 1 _) ⟩ + 2 * suc (Even.j (e2 i en)) ∎ where open ≡-Reasoning + +record Odd (i : ℕ) : Set where + field + j : ℕ + is-twice : i ≡ suc (2 * j ) + +odd2 : (i : ℕ) → ¬ even i → even (suc i) +odd2 zero ne = ⊥-elim ( ne tt ) +odd2 (suc zero) ne = tt +odd2 (suc (suc i)) ne = odd2 i ne + +odd3 : (i : ℕ) → ¬ even i → Odd i +odd3 zero ne = ⊥-elim ( ne tt ) +odd3 (suc zero) ne = record { j = 0 ; is-twice = refl } +odd3 (suc (suc i)) ne = record { j = Even.j (e2 (suc i) (odd2 i ne)) ; is-twice = odd31 } where + odd31 : suc (suc i) ≡ suc (2 * Even.j (e2 (suc i) (odd2 i ne))) + odd31 = begin + suc (suc i) ≡⟨ cong suc (Even.is-twice (e2 (suc i) (odd2 i ne))) ⟩ + suc (2 * (Even.j (e2 (suc i) (odd2 i ne)))) ∎ where open ≡-Reasoning + +odd4 : (i : ℕ) → even i → ¬ even ( suc i ) +odd4 (suc (suc i)) en en1 = odd4 i en en1 +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/automaton-in-agda/src/fin.agda Sun Jun 13 20:45:17 2021 +0900 @@ -0,0 +1,117 @@ +{-# OPTIONS --allow-unsolved-metas #-} + +module fin where + +open import Data.Fin hiding (_<_ ; _≤_ ) +open import Data.Fin.Properties hiding ( <-trans ) +open import Data.Nat +open import logic +open import nat +open import Relation.Binary.PropositionalEquality + + +-- toℕ<n +fin<n : {n : ℕ} {f : Fin n} → toℕ f < n +fin<n {_} {zero} = s≤s z≤n +fin<n {suc n} {suc f} = s≤s (fin<n {n} {f}) + +-- toℕ≤n +fin≤n : {n : ℕ} (f : Fin (suc n)) → toℕ f ≤ n +fin≤n {_} zero = z≤n +fin≤n {suc n} (suc f) = s≤s (fin≤n {n} f) + +pred<n : {n : ℕ} {f : Fin (suc n)} → n > 0 → Data.Nat.pred (toℕ f) < n +pred<n {suc n} {zero} (s≤s z≤n) = s≤s z≤n +pred<n {suc n} {suc f} (s≤s z≤n) = fin<n + +fin<asa : {n : ℕ} → toℕ (fromℕ< {n} a<sa) ≡ n +fin<asa = toℕ-fromℕ< nat.a<sa + +-- fromℕ<-toℕ +toℕ→from : {n : ℕ} {x : Fin (suc n)} → toℕ x ≡ n → fromℕ n ≡ x +toℕ→from {0} {zero} refl = refl +toℕ→from {suc n} {suc x} eq = cong (λ k → suc k ) ( toℕ→from {n} {x} (cong (λ k → Data.Nat.pred k ) eq )) + +0≤fmax : {n : ℕ } → (# 0) Data.Fin.≤ fromℕ< {n} a<sa +0≤fmax = subst (λ k → 0 ≤ k ) (sym (toℕ-fromℕ< a<sa)) z≤n + +0<fmax : {n : ℕ } → (# 0) Data.Fin.< fromℕ< {suc n} a<sa +0<fmax = subst (λ k → 0 < k ) (sym (toℕ-fromℕ< a<sa)) (s≤s z≤n) + +-- toℕ-injective +i=j : {n : ℕ} (i j : Fin n) → toℕ i ≡ toℕ j → i ≡ j +i=j {suc n} zero zero refl = refl +i=j {suc n} (suc i) (suc j) eq = cong ( λ k → suc k ) ( i=j i j (cong ( λ k → Data.Nat.pred k ) eq) ) + +-- raise 1 +fin+1 : { n : ℕ } → Fin n → Fin (suc n) +fin+1 zero = zero +fin+1 (suc x) = suc (fin+1 x) + +open import Data.Nat.Properties as NatP hiding ( _≟_ ) + +fin+1≤ : { i n : ℕ } → (a : i < n) → fin+1 (fromℕ< a) ≡ fromℕ< (<-trans a a<sa) +fin+1≤ {0} {suc i} (s≤s z≤n) = refl +fin+1≤ {suc n} {suc (suc i)} (s≤s (s≤s a)) = cong (λ k → suc k ) ( fin+1≤ {n} {suc i} (s≤s a) ) + +fin+1-toℕ : { n : ℕ } → { x : Fin n} → toℕ (fin+1 x) ≡ toℕ x +fin+1-toℕ {suc n} {zero} = refl +fin+1-toℕ {suc n} {suc x} = cong (λ k → suc k ) (fin+1-toℕ {n} {x}) + +open import Relation.Nullary +open import Data.Empty + +fin-1 : { n : ℕ } → (x : Fin (suc n)) → ¬ (x ≡ zero ) → Fin n +fin-1 zero ne = ⊥-elim (ne refl ) +fin-1 {n} (suc x) ne = x + +fin-1-sx : { n : ℕ } → (x : Fin n) → fin-1 (suc x) (λ ()) ≡ x +fin-1-sx zero = refl +fin-1-sx (suc x) = refl + +fin-1-xs : { n : ℕ } → (x : Fin (suc n)) → (ne : ¬ (x ≡ zero )) → suc (fin-1 x ne ) ≡ x +fin-1-xs zero ne = ⊥-elim ( ne refl ) +fin-1-xs (suc x) ne = refl + +-- suc-injective +-- suc-eq : {n : ℕ } {x y : Fin n} → Fin.suc x ≡ Fin.suc y → x ≡ y +-- suc-eq {n} {x} {y} eq = subst₂ (λ j k → j ≡ k ) {!!} {!!} (cong (λ k → Data.Fin.pred k ) eq ) + +-- this is refl +lemma3 : {a b : ℕ } → (lt : a < b ) → fromℕ< (s≤s lt) ≡ suc (fromℕ< lt) +lemma3 (s≤s lt) = refl + +-- fromℕ<-toℕ +lemma12 : {n m : ℕ } → (n<m : n < m ) → (f : Fin m ) → toℕ f ≡ n → f ≡ fromℕ< n<m +lemma12 {zero} {suc m} (s≤s z≤n) zero refl = refl +lemma12 {suc n} {suc m} (s≤s n<m) (suc f) refl = cong suc ( lemma12 {n} {m} n<m f refl ) + +open import Relation.Binary.HeterogeneousEquality as HE using (_≅_ ) +open import Data.Fin.Properties + +-- <-irrelevant +<-nat=irr : {i j n : ℕ } → ( i ≡ j ) → {i<n : i < n } → {j<n : j < n } → i<n ≅ j<n +<-nat=irr {zero} {zero} {suc n} refl {s≤s z≤n} {s≤s z≤n} = HE.refl +<-nat=irr {suc i} {suc i} {suc n} refl {s≤s i<n} {s≤s j<n} = HE.cong (λ k → s≤s k ) ( <-nat=irr {i} {i} {n} refl ) + +lemma8 : {i j n : ℕ } → ( i ≡ j ) → {i<n : i < n } → {j<n : j < n } → i<n ≅ j<n +lemma8 {zero} {zero} {suc n} refl {s≤s z≤n} {s≤s z≤n} = HE.refl +lemma8 {suc i} {suc i} {suc n} refl {s≤s i<n} {s≤s j<n} = HE.cong (λ k → s≤s k ) ( lemma8 {i} {i} {n} refl ) + +-- fromℕ<-irrelevant +lemma10 : {n i j : ℕ } → ( i ≡ j ) → {i<n : i < n } → {j<n : j < n } → fromℕ< i<n ≡ fromℕ< j<n +lemma10 {n} refl = HE.≅-to-≡ (HE.cong (λ k → fromℕ< k ) (lemma8 refl )) + +lemma31 : {a b c : ℕ } → { a<b : a < b } { b<c : b < c } { a<c : a < c } → NatP.<-trans a<b b<c ≡ a<c +lemma31 {a} {b} {c} {a<b} {b<c} {a<c} = HE.≅-to-≡ (lemma8 refl) + +-- toℕ-fromℕ< +lemma11 : {n m : ℕ } {x : Fin n } → (n<m : n < m ) → toℕ (fromℕ< (NatP.<-trans (toℕ<n x) n<m)) ≡ toℕ x +lemma11 {n} {m} {x} n<m = begin + toℕ (fromℕ< (NatP.<-trans (toℕ<n x) n<m)) + ≡⟨ toℕ-fromℕ< _ ⟩ + toℕ x + ∎ where + open ≡-Reasoning + +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/automaton-in-agda/src/finiteSet.agda Sun Jun 13 20:45:17 2021 +0900 @@ -0,0 +1,42 @@ +{-# OPTIONS --allow-unsolved-metas #-} +module finiteSet where + +open import Data.Nat hiding ( _≟_ ) +open import Data.Fin renaming ( _<_ to _<<_ ) hiding (_≤_) +-- open import Data.Fin.Properties +open import Data.Empty +open import Relation.Nullary +open import Relation.Binary.Definitions +open import Relation.Binary.PropositionalEquality +open import logic +open import nat +open import Data.Nat.Properties hiding ( _≟_ ) + +open import Relation.Binary.HeterogeneousEquality as HE using (_≅_ ) + +record FiniteSet ( Q : Set ) : Set where + field + finite : ℕ + Q←F : Fin finite → Q + F←Q : Q → Fin finite + finiso→ : (q : Q) → Q←F ( F←Q q ) ≡ q + finiso← : (f : Fin finite ) → F←Q ( Q←F f ) ≡ f + exists1 : (m : ℕ ) → m Data.Nat.≤ finite → (Q → Bool) → Bool + exists1 zero _ _ = false + exists1 ( suc m ) m<n p = p (Q←F (fromℕ< {m} {finite} m<n)) \/ exists1 m (≤to< m<n) p + exists : ( Q → Bool ) → Bool + exists p = exists1 finite ≤-refl p + + open import Data.List + list1 : (m : ℕ ) → m Data.Nat.≤ finite → (Q → Bool) → List Q + list1 zero _ _ = [] + list1 ( suc m ) m<n p with bool-≡-? (p (Q←F (fromℕ< {m} {finite} m<n))) true + ... | yes _ = Q←F (fromℕ< {m} {finite} m<n) ∷ list1 m (≤to< m<n) p + ... | no _ = list1 m (≤to< m<n) p + to-list : ( Q → Bool ) → List Q + to-list p = list1 finite ≤-refl p + + equal? : Q → Q → Bool + equal? q0 q1 with F←Q q0 ≟ F←Q q1 + ... | yes p = true + ... | no ¬p = false
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/automaton-in-agda/src/finiteSetUtil.agda Sun Jun 13 20:45:17 2021 +0900 @@ -0,0 +1,461 @@ +{-# OPTIONS --allow-unsolved-metas #-} + +module finiteSetUtil where + +open import Data.Nat hiding ( _≟_ ) +open import Data.Fin renaming ( _<_ to _<<_ ) hiding (_≤_) +open import Data.Fin.Properties +open import Data.Empty +open import Relation.Nullary +open import Relation.Binary.Definitions +open import Relation.Binary.PropositionalEquality +open import logic +open import nat +open import finiteSet +open import fin +open import Data.Nat.Properties as NatP hiding ( _≟_ ) +open import Relation.Binary.HeterogeneousEquality as HE using (_≅_ ) + +record Found ( Q : Set ) (p : Q → Bool ) : Set where + field + found-q : Q + found-p : p found-q ≡ true + +module _ {Q : Set } (F : FiniteSet Q) where + open FiniteSet F + equal→refl : { x y : Q } → equal? x y ≡ true → x ≡ y + equal→refl {q0} {q1} eq with F←Q q0 ≟ F←Q q1 + equal→refl {q0} {q1} refl | yes eq = begin + q0 + ≡⟨ sym ( finiso→ q0) ⟩ + Q←F (F←Q q0) + ≡⟨ cong (λ k → Q←F k ) eq ⟩ + Q←F (F←Q q1) + ≡⟨ finiso→ q1 ⟩ + q1 + ∎ where open ≡-Reasoning + End : (m : ℕ ) → (p : Q → Bool ) → Set + End m p = (i : Fin finite) → m ≤ toℕ i → p (Q←F i ) ≡ false + first-end : ( p : Q → Bool ) → End finite p + first-end p i i>n = ⊥-elim (nat-≤> i>n (fin<n {finite} {i}) ) + next-end : {m : ℕ } → ( p : Q → Bool ) → End (suc m) p + → (m<n : m < finite ) → p (Q←F (fromℕ< m<n )) ≡ false + → End m p + next-end {m} p prev m<n np i m<i with NatP.<-cmp m (toℕ i) + next-end p prev m<n np i m<i | tri< a ¬b ¬c = prev i a + next-end p prev m<n np i m<i | tri> ¬a ¬b c = ⊥-elim ( nat-≤> m<i c ) + next-end {m} p prev m<n np i m<i | tri≈ ¬a b ¬c = subst ( λ k → p (Q←F k) ≡ false) (m<n=i i b m<n ) np where + m<n=i : {n : ℕ } (i : Fin n) {m : ℕ } → m ≡ (toℕ i) → (m<n : m < n ) → fromℕ< m<n ≡ i + m<n=i i eq m<n = {!!} -- toℕ-inject (fromℕ≤ ?) i (subst (λ k → k ≡ toℕ i) (sym (toℕ-fromℕ≤ m<n)) eq ) + found : { p : Q → Bool } → (q : Q ) → p q ≡ true → exists p ≡ true + found {p} q pt = found1 finite (NatP.≤-refl ) ( first-end p ) where + found1 : (m : ℕ ) (m<n : m Data.Nat.≤ finite ) → ((i : Fin finite) → m ≤ toℕ i → p (Q←F i ) ≡ false ) → exists1 m m<n p ≡ true + found1 0 m<n end = ⊥-elim ( ¬-bool (subst (λ k → k ≡ false ) (cong (λ k → p k) (finiso→ q) ) (end (F←Q q) z≤n )) pt ) + found1 (suc m) m<n end with bool-≡-? (p (Q←F (fromℕ< m<n))) true + found1 (suc m) m<n end | yes eq = subst (λ k → k \/ exists1 m (≤to< m<n) p ≡ true ) (sym eq) (bool-or-4 {exists1 m (≤to< m<n) p} ) + found1 (suc m) m<n end | no np = begin + p (Q←F (fromℕ< m<n)) \/ exists1 m (≤to< m<n) p + ≡⟨ bool-or-1 (¬-bool-t np ) ⟩ + exists1 m (≤to< m<n) p + ≡⟨ found1 m (≤to< m<n) (next-end p end m<n (¬-bool-t np )) ⟩ + true + ∎ where open ≡-Reasoning + + + +record ISO (A B : Set) : Set where + field + A←B : B → A + B←A : A → B + iso← : (q : A) → A←B ( B←A q ) ≡ q + iso→ : (f : B) → B←A ( A←B f ) ≡ f + +iso-fin : {A B : Set} → FiniteSet A → ISO A B → FiniteSet B +iso-fin {A} {B} fin iso = record { + Q←F = λ f → ISO.B←A iso ( FiniteSet.Q←F fin f ) + ; F←Q = λ b → FiniteSet.F←Q fin ( ISO.A←B iso b ) + ; finiso→ = finiso→ + ; finiso← = finiso← + } where + finiso→ : (q : B) → ISO.B←A iso (FiniteSet.Q←F fin (FiniteSet.F←Q fin (ISO.A←B iso q))) ≡ q + finiso→ q = begin + ISO.B←A iso (FiniteSet.Q←F fin (FiniteSet.F←Q fin (ISO.A←B iso q))) + ≡⟨ cong (λ k → ISO.B←A iso k ) (FiniteSet.finiso→ fin _ ) ⟩ + ISO.B←A iso (ISO.A←B iso q) + ≡⟨ ISO.iso→ iso _ ⟩ + q + ∎ where + open ≡-Reasoning + finiso← : (f : Fin (FiniteSet.finite fin ))→ FiniteSet.F←Q fin (ISO.A←B iso (ISO.B←A iso (FiniteSet.Q←F fin f))) ≡ f + finiso← f = begin + FiniteSet.F←Q fin (ISO.A←B iso (ISO.B←A iso (FiniteSet.Q←F fin f))) + ≡⟨ cong (λ k → FiniteSet.F←Q fin k ) (ISO.iso← iso _) ⟩ + FiniteSet.F←Q fin (FiniteSet.Q←F fin f) + ≡⟨ FiniteSet.finiso← fin _ ⟩ + f + ∎ where + open ≡-Reasoning + +data One : Set where + one : One + +fin-∨1 : {B : Set} → (fb : FiniteSet B ) → FiniteSet (One ∨ B) +fin-∨1 {B} fb = record { + Q←F = Q←F + ; F←Q = F←Q + ; finiso→ = finiso→ + ; finiso← = finiso← + } where + b = FiniteSet.finite fb + Q←F : Fin (suc b) → One ∨ B + Q←F zero = case1 one + Q←F (suc f) = case2 (FiniteSet.Q←F fb f) + F←Q : One ∨ B → Fin (suc b) + F←Q (case1 one) = zero + F←Q (case2 f ) = suc (FiniteSet.F←Q fb f) + finiso→ : (q : One ∨ B) → Q←F (F←Q q) ≡ q + finiso→ (case1 one) = refl + finiso→ (case2 b) = cong (λ k → case2 k ) (FiniteSet.finiso→ fb b) + finiso← : (q : Fin (suc b)) → F←Q (Q←F q) ≡ q + finiso← zero = refl + finiso← (suc f) = cong ( λ k → suc k ) (FiniteSet.finiso← fb f) + + +fin-∨2 : {B : Set} → ( a : ℕ ) → FiniteSet B → FiniteSet (Fin a ∨ B) +fin-∨2 {B} zero fb = iso-fin fb iso where + iso : ISO B (Fin zero ∨ B) + iso = record { + A←B = A←B + ; B←A = λ b → case2 b + ; iso→ = iso→ + ; iso← = λ _ → refl + } where + A←B : Fin zero ∨ B → B + A←B (case2 x) = x + iso→ : (f : Fin zero ∨ B ) → case2 (A←B f) ≡ f + iso→ (case2 x) = refl +fin-∨2 {B} (suc a) fb = iso-fin (fin-∨1 (fin-∨2 a fb) ) iso + where + iso : ISO (One ∨ (Fin a ∨ B) ) (Fin (suc a) ∨ B) + ISO.A←B iso (case1 zero) = case1 one + ISO.A←B iso (case1 (suc f)) = case2 (case1 f) + ISO.A←B iso (case2 b) = case2 (case2 b) + ISO.B←A iso (case1 one) = case1 zero + ISO.B←A iso (case2 (case1 f)) = case1 (suc f) + ISO.B←A iso (case2 (case2 b)) = case2 b + ISO.iso← iso (case1 one) = refl + ISO.iso← iso (case2 (case1 x)) = refl + ISO.iso← iso (case2 (case2 x)) = refl + ISO.iso→ iso (case1 zero) = refl + ISO.iso→ iso (case1 (suc x)) = refl + ISO.iso→ iso (case2 x) = refl + + +FiniteSet→Fin : {A : Set} → (fin : FiniteSet A ) → ISO (Fin (FiniteSet.finite fin)) A +ISO.A←B (FiniteSet→Fin fin) f = FiniteSet.F←Q fin f +ISO.B←A (FiniteSet→Fin fin) f = FiniteSet.Q←F fin f +ISO.iso← (FiniteSet→Fin fin) = FiniteSet.finiso← fin +ISO.iso→ (FiniteSet→Fin fin) = FiniteSet.finiso→ fin + + +fin-∨ : {A B : Set} → FiniteSet A → FiniteSet B → FiniteSet (A ∨ B) +fin-∨ {A} {B} fa fb = iso-fin (fin-∨2 a fb ) iso2 where + a = FiniteSet.finite fa + ia = FiniteSet→Fin fa + iso2 : ISO (Fin a ∨ B ) (A ∨ B) + ISO.A←B iso2 (case1 x) = case1 ( ISO.A←B ia x ) + ISO.A←B iso2 (case2 x) = case2 x + ISO.B←A iso2 (case1 x) = case1 ( ISO.B←A ia x ) + ISO.B←A iso2 (case2 x) = case2 x + ISO.iso← iso2 (case1 x) = cong ( λ k → case1 k ) (ISO.iso← ia x) + ISO.iso← iso2 (case2 x) = refl + ISO.iso→ iso2 (case1 x) = cong ( λ k → case1 k ) (ISO.iso→ ia x) + ISO.iso→ iso2 (case2 x) = refl + +open import Data.Product + +fin-× : {A B : Set} → FiniteSet A → FiniteSet B → FiniteSet (A × B) +fin-× {A} {B} fa fb with FiniteSet→Fin fa +... | a=f = iso-fin (fin-×-f a ) iso-1 where + a = FiniteSet.finite fa + b = FiniteSet.finite fb + iso-1 : ISO (Fin a × B) ( A × B ) + ISO.A←B iso-1 x = ( FiniteSet.F←Q fa (proj₁ x) , proj₂ x) + ISO.B←A iso-1 x = ( FiniteSet.Q←F fa (proj₁ x) , proj₂ x) + ISO.iso← iso-1 x = lemma where + lemma : (FiniteSet.F←Q fa (FiniteSet.Q←F fa (proj₁ x)) , proj₂ x) ≡ ( proj₁ x , proj₂ x ) + lemma = cong ( λ k → ( k , proj₂ x ) ) (FiniteSet.finiso← fa _ ) + ISO.iso→ iso-1 x = cong ( λ k → ( k , proj₂ x ) ) (FiniteSet.finiso→ fa _ ) + + iso-2 : {a : ℕ } → ISO (B ∨ (Fin a × B)) (Fin (suc a) × B) + ISO.A←B iso-2 (zero , b ) = case1 b + ISO.A←B iso-2 (suc fst , b ) = case2 ( fst , b ) + ISO.B←A iso-2 (case1 b) = ( zero , b ) + ISO.B←A iso-2 (case2 (a , b )) = ( suc a , b ) + ISO.iso← iso-2 (case1 x) = refl + ISO.iso← iso-2 (case2 x) = refl + ISO.iso→ iso-2 (zero , b ) = refl + ISO.iso→ iso-2 (suc a , b ) = refl + + fin-×-f : ( a : ℕ ) → FiniteSet ((Fin a) × B) + fin-×-f zero = record { Q←F = λ () ; F←Q = λ () ; finiso→ = λ () ; finiso← = λ () ; finite = 0 } + fin-×-f (suc a) = iso-fin ( fin-∨ fb ( fin-×-f a ) ) iso-2 + +open _∧_ + +fin-∧ : {A B : Set} → FiniteSet A → FiniteSet B → FiniteSet (A ∧ B) +fin-∧ {A} {B} fa fb with FiniteSet→Fin fa -- same thing for our tool +... | a=f = iso-fin (fin-×-f a ) iso-1 where + a = FiniteSet.finite fa + b = FiniteSet.finite fb + iso-1 : ISO (Fin a ∧ B) ( A ∧ B ) + ISO.A←B iso-1 x = record { proj1 = FiniteSet.F←Q fa (proj1 x) ; proj2 = proj2 x} + ISO.B←A iso-1 x = record { proj1 = FiniteSet.Q←F fa (proj1 x) ; proj2 = proj2 x} + ISO.iso← iso-1 x = lemma where + lemma : record { proj1 = FiniteSet.F←Q fa (FiniteSet.Q←F fa (proj1 x)) ; proj2 = proj2 x} ≡ record {proj1 = proj1 x ; proj2 = proj2 x } + lemma = cong ( λ k → record {proj1 = k ; proj2 = proj2 x } ) (FiniteSet.finiso← fa _ ) + ISO.iso→ iso-1 x = cong ( λ k → record {proj1 = k ; proj2 = proj2 x } ) (FiniteSet.finiso→ fa _ ) + + iso-2 : {a : ℕ } → ISO (B ∨ (Fin a ∧ B)) (Fin (suc a) ∧ B) + ISO.A←B iso-2 (record { proj1 = zero ; proj2 = b }) = case1 b + ISO.A←B iso-2 (record { proj1 = suc fst ; proj2 = b }) = case2 ( record { proj1 = fst ; proj2 = b } ) + ISO.B←A iso-2 (case1 b) = record {proj1 = zero ; proj2 = b } + ISO.B←A iso-2 (case2 (record { proj1 = a ; proj2 = b })) = record { proj1 = suc a ; proj2 = b } + ISO.iso← iso-2 (case1 x) = refl + ISO.iso← iso-2 (case2 x) = refl + ISO.iso→ iso-2 (record { proj1 = zero ; proj2 = b }) = refl + ISO.iso→ iso-2 (record { proj1 = suc a ; proj2 = b }) = refl + + fin-×-f : ( a : ℕ ) → FiniteSet ((Fin a) ∧ B) + fin-×-f zero = record { Q←F = λ () ; F←Q = λ () ; finiso→ = λ () ; finiso← = λ () ; finite = 0 } + fin-×-f (suc a) = iso-fin ( fin-∨ fb ( fin-×-f a ) ) iso-2 + +-- import Data.Nat.DivMod + +open import Data.Vec +import Data.Product + +exp2 : (n : ℕ ) → exp 2 (suc n) ≡ exp 2 n Data.Nat.+ exp 2 n +exp2 n = begin + exp 2 (suc n) + ≡⟨⟩ + 2 * ( exp 2 n ) + ≡⟨ *-comm 2 (exp 2 n) ⟩ + ( exp 2 n ) * 2 + ≡⟨ *-suc ( exp 2 n ) 1 ⟩ + (exp 2 n ) Data.Nat.+ ( exp 2 n ) * 1 + ≡⟨ cong ( λ k → (exp 2 n ) Data.Nat.+ k ) (proj₂ *-identity (exp 2 n) ) ⟩ + exp 2 n Data.Nat.+ exp 2 n + ∎ where + open ≡-Reasoning + open Data.Product + +cast-iso : {n m : ℕ } → (eq : n ≡ m ) → (f : Fin m ) → cast eq ( cast (sym eq ) f) ≡ f +cast-iso refl zero = refl +cast-iso refl (suc f) = cong ( λ k → suc k ) ( cast-iso refl f ) + + +fin2List : {n : ℕ } → FiniteSet (Vec Bool n) +fin2List {zero} = record { + Q←F = λ _ → Vec.[] + ; F←Q = λ _ → # 0 + ; finiso→ = finiso→ + ; finiso← = finiso← + } where + Q = Vec Bool zero + finiso→ : (q : Q) → [] ≡ q + finiso→ [] = refl + finiso← : (f : Fin (exp 2 zero)) → # 0 ≡ f + finiso← zero = refl +fin2List {suc n} = subst (λ k → FiniteSet (Vec Bool (suc n)) ) (sym (exp2 n)) ( iso-fin (fin-∨ (fin2List ) (fin2List )) iso ) + where + QtoR : Vec Bool (suc n) → Vec Bool n ∨ Vec Bool n + QtoR ( true ∷ x ) = case1 x + QtoR ( false ∷ x ) = case2 x + RtoQ : Vec Bool n ∨ Vec Bool n → Vec Bool (suc n) + RtoQ ( case1 x ) = true ∷ x + RtoQ ( case2 x ) = false ∷ x + isoRQ : (x : Vec Bool (suc n) ) → RtoQ ( QtoR x ) ≡ x + isoRQ (true ∷ _ ) = refl + isoRQ (false ∷ _ ) = refl + isoQR : (x : Vec Bool n ∨ Vec Bool n ) → QtoR ( RtoQ x ) ≡ x + isoQR (case1 x) = refl + isoQR (case2 x) = refl + iso : ISO (Vec Bool n ∨ Vec Bool n) (Vec Bool (suc n)) + iso = record { A←B = QtoR ; B←A = RtoQ ; iso← = isoQR ; iso→ = isoRQ } + +F2L : {Q : Set } {n : ℕ } → (fin : FiniteSet Q ) → n < suc (FiniteSet.finite fin) → ( (q : Q) → toℕ (FiniteSet.F←Q fin q ) < n → Bool ) → Vec Bool n +F2L {Q} {zero} fin _ Q→B = [] +F2L {Q} {suc n} fin (s≤s n<m) Q→B = Q→B (FiniteSet.Q←F fin (fromℕ< n<m)) lemma6 ∷ F2L {Q} fin (NatP.<-trans n<m a<sa ) qb1 where + lemma6 : toℕ (FiniteSet.F←Q fin (FiniteSet.Q←F fin (fromℕ< n<m))) < suc n + lemma6 = subst (λ k → toℕ k < suc n ) (sym (FiniteSet.finiso← fin _ )) (subst (λ k → k < suc n) (sym (toℕ-fromℕ< n<m )) a<sa ) + qb1 : (q : Q) → toℕ (FiniteSet.F←Q fin q) < n → Bool + qb1 q q<n = Q→B q (NatP.<-trans q<n a<sa) + +List2Func : { Q : Set } → {n : ℕ } → (fin : FiniteSet Q ) → n < suc (FiniteSet.finite fin) → Vec Bool n → Q → Bool +List2Func {Q} {zero} fin (s≤s z≤n) [] q = false +List2Func {Q} {suc n} fin (s≤s n<m) (h ∷ t) q with FiniteSet.F←Q fin q ≟ fromℕ< n<m +... | yes _ = h +... | no _ = List2Func {Q} fin (NatP.<-trans n<m a<sa ) t q + +open import Level renaming ( suc to Suc ; zero to Zero) +open import Axiom.Extensionality.Propositional +postulate f-extensionality : { n : Level} → Axiom.Extensionality.Propositional.Extensionality n n + +F2L-iso : { Q : Set } → (fin : FiniteSet Q ) → (x : Vec Bool (FiniteSet.finite fin) ) → F2L fin a<sa (λ q _ → List2Func fin a<sa x q ) ≡ x +F2L-iso {Q} fin x = f2l m a<sa x where + m = FiniteSet.finite fin + f2l : (n : ℕ ) → (n<m : n < suc m )→ (x : Vec Bool n ) → F2L fin n<m (λ q q<n → List2Func fin n<m x q ) ≡ x + f2l zero (s≤s z≤n) [] = refl + f2l (suc n) (s≤s n<m) (h ∷ t ) = lemma1 lemma2 lemma3f where + lemma1 : {n : ℕ } → {h h1 : Bool } → {t t1 : Vec Bool n } → h ≡ h1 → t ≡ t1 → h ∷ t ≡ h1 ∷ t1 + lemma1 refl refl = refl + lemma2 : List2Func fin (s≤s n<m) (h ∷ t) (FiniteSet.Q←F fin (fromℕ< n<m)) ≡ h + lemma2 with FiniteSet.F←Q fin (FiniteSet.Q←F fin (fromℕ< n<m)) ≟ fromℕ< n<m + lemma2 | yes p = refl + lemma2 | no ¬p = ⊥-elim ( ¬p (FiniteSet.finiso← fin _) ) + lemma4 : (q : Q ) → toℕ (FiniteSet.F←Q fin q ) < n → List2Func fin (s≤s n<m) (h ∷ t) q ≡ List2Func fin (NatP.<-trans n<m a<sa) t q + lemma4 q _ with FiniteSet.F←Q fin q ≟ fromℕ< n<m + lemma4 q lt | yes p = ⊥-elim ( nat-≡< (toℕ-fromℕ< n<m) (lemma5 n lt (cong (λ k → toℕ k) p))) where + lemma5 : {j k : ℕ } → ( n : ℕ) → suc j ≤ n → j ≡ k → k < n + lemma5 {zero} (suc n) (s≤s z≤n) refl = s≤s z≤n + lemma5 {suc j} (suc n) (s≤s lt) refl = s≤s (lemma5 {j} n lt refl) + lemma4 q _ | no ¬p = refl + lemma3f : F2L fin (NatP.<-trans n<m a<sa) (λ q q<n → List2Func fin (s≤s n<m) (h ∷ t) q ) ≡ t + lemma3f = begin + F2L fin (NatP.<-trans n<m a<sa) (λ q q<n → List2Func fin (s≤s n<m) (h ∷ t) q ) + ≡⟨ cong (λ k → F2L fin (NatP.<-trans n<m a<sa) ( λ q q<n → k q q<n )) + (f-extensionality ( λ q → + (f-extensionality ( λ q<n → lemma4 q q<n )))) ⟩ + F2L fin (NatP.<-trans n<m a<sa) (λ q q<n → List2Func fin (NatP.<-trans n<m a<sa) t q ) + ≡⟨ f2l n (NatP.<-trans n<m a<sa ) t ⟩ + t + ∎ where + open ≡-Reasoning + + +L2F : {Q : Set } {n : ℕ } → (fin : FiniteSet Q ) → n < suc (FiniteSet.finite fin) → Vec Bool n → (q : Q ) → toℕ (FiniteSet.F←Q fin q ) < n → Bool +L2F fin n<m x q q<n = List2Func fin n<m x q + +L2F-iso : { Q : Set } → (fin : FiniteSet Q ) → (f : Q → Bool ) → (q : Q ) → (L2F fin a<sa (F2L fin a<sa (λ q _ → f q) )) q (toℕ<n _) ≡ f q +L2F-iso {Q} fin f q = l2f m a<sa (toℕ<n _) where + m = FiniteSet.finite fin + lemma11f : {n : ℕ } → (n<m : n < m ) → ¬ ( FiniteSet.F←Q fin q ≡ fromℕ< n<m ) → toℕ (FiniteSet.F←Q fin q) ≤ n → toℕ (FiniteSet.F←Q fin q) < n + lemma11f n<m ¬q=n q≤n = lemma13 n<m (contra-position (lemma12 n<m _) ¬q=n ) q≤n where + lemma13 : {n nq : ℕ } → (n<m : n < m ) → ¬ ( nq ≡ n ) → nq ≤ n → nq < n + lemma13 {0} {0} (s≤s z≤n) nt z≤n = ⊥-elim ( nt refl ) + lemma13 {suc _} {0} (s≤s (s≤s n<m)) nt z≤n = s≤s z≤n + lemma13 {suc n} {suc nq} n<m nt (s≤s nq≤n) = s≤s (lemma13 {n} {nq} (NatP.<-trans a<sa n<m ) (λ eq → nt ( cong ( λ k → suc k ) eq )) nq≤n) + lemma3f : {a b : ℕ } → (lt : a < b ) → fromℕ< (s≤s lt) ≡ suc (fromℕ< lt) + lemma3f (s≤s lt) = refl + lemma12f : {n m : ℕ } → (n<m : n < m ) → (f : Fin m ) → toℕ f ≡ n → f ≡ fromℕ< n<m + lemma12f {zero} {suc m} (s≤s z≤n) zero refl = refl + lemma12f {suc n} {suc m} (s≤s n<m) (suc f) refl = subst ( λ k → suc f ≡ k ) (sym (lemma3f n<m) ) ( cong ( λ k → suc k ) ( lemma12f {n} {m} n<m f refl ) ) + l2f : (n : ℕ ) → (n<m : n < suc m ) → (q<n : toℕ (FiniteSet.F←Q fin q ) < n ) → (L2F fin n<m (F2L fin n<m (λ q _ → f q))) q q<n ≡ f q + l2f zero (s≤s z≤n) () + l2f (suc n) (s≤s n<m) (s≤s n<q) with FiniteSet.F←Q fin q ≟ fromℕ< n<m + l2f (suc n) (s≤s n<m) (s≤s n<q) | yes p = begin + f (FiniteSet.Q←F fin (fromℕ< n<m)) + ≡⟨ cong ( λ k → f (FiniteSet.Q←F fin k )) (sym p) ⟩ + f (FiniteSet.Q←F fin ( FiniteSet.F←Q fin q )) + ≡⟨ cong ( λ k → f k ) (FiniteSet.finiso→ fin _ ) ⟩ + f q + ∎ where + open ≡-Reasoning + l2f (suc n) (s≤s n<m) (s≤s n<q) | no ¬p = l2f n (NatP.<-trans n<m a<sa) (lemma11f n<m ¬p n<q) + +fin→ : {A : Set} → FiniteSet A → FiniteSet (A → Bool ) +fin→ {A} fin = iso-fin fin2List iso where + a = FiniteSet.finite fin + iso : ISO (Vec Bool a ) (A → Bool) + ISO.A←B iso x = F2L fin a<sa ( λ q _ → x q ) + ISO.B←A iso x = List2Func fin a<sa x + ISO.iso← iso x = F2L-iso fin x + ISO.iso→ iso x = lemma where + lemma : List2Func fin a<sa (F2L fin a<sa (λ q _ → x q)) ≡ x + lemma = f-extensionality ( λ q → L2F-iso fin x q ) + + +Fin2Finite : ( n : ℕ ) → FiniteSet (Fin n) +Fin2Finite n = record { F←Q = λ x → x ; Q←F = λ x → x ; finiso← = λ q → refl ; finiso→ = λ q → refl } + +data fin-less { n : ℕ } { A : Set } (fa : FiniteSet A ) (n<m : n < FiniteSet.finite fa ) : Set where + elm1 : (elm : A ) → toℕ (FiniteSet.F←Q fa elm ) < n → fin-less fa n<m + +get-elm : { n : ℕ } { A : Set } {fa : FiniteSet A } {n<m : n < FiniteSet.finite fa } → fin-less fa n<m → A +get-elm (elm1 a _ ) = a + +get-< : { n : ℕ } { A : Set } {fa : FiniteSet A } {n<m : n < FiniteSet.finite fa }→ (f : fin-less fa n<m ) → toℕ (FiniteSet.F←Q fa (get-elm f )) < n +get-< (elm1 _ b ) = b + +fin-less-cong : { n : ℕ } { A : Set } (fa : FiniteSet A ) (n<m : n < FiniteSet.finite fa ) + → (x y : fin-less fa n<m ) → get-elm {n} {A} {fa} x ≡ get-elm {n} {A} {fa} y → get-< x ≅ get-< y → x ≡ y +fin-less-cong fa n<m (elm1 elm x) (elm1 elm x) refl HE.refl = refl + +fin-< : {A : Set} → { n : ℕ } → (fa : FiniteSet A ) → (n<m : n < FiniteSet.finite fa ) → FiniteSet (fin-less fa n<m ) +fin-< {A} {n} fa n<m = iso-fin (Fin2Finite n) iso where + m = FiniteSet.finite fa + iso : ISO (Fin n) (fin-less fa n<m ) + lemma8f : {i j n : ℕ } → ( i ≡ j ) → {i<n : i < n } → {j<n : j < n } → i<n ≅ j<n + lemma8f {zero} {zero} {suc n} refl {s≤s z≤n} {s≤s z≤n} = HE.refl + lemma8f {suc i} {suc i} {suc n} refl {s≤s i<n} {s≤s j<n} = HE.cong (λ k → s≤s k ) ( lemma8f {i} {i} refl ) + lemma10f : {n i j : ℕ } → ( i ≡ j ) → {i<n : i < n } → {j<n : j < n } → fromℕ< i<n ≡ fromℕ< j<n + lemma10f refl = HE.≅-to-≡ (HE.cong (λ k → fromℕ< k ) (lemma8f refl )) + lemma3f : {a b c : ℕ } → { a<b : a < b } { b<c : b < c } { a<c : a < c } → NatP.<-trans a<b b<c ≡ a<c + lemma3f {a} {b} {c} {a<b} {b<c} {a<c} = HE.≅-to-≡ (lemma8f refl) + lemma11f : {n : ℕ } {x : Fin n } → (n<m : n < m ) → toℕ (fromℕ< (NatP.<-trans (toℕ<n x) n<m)) ≡ toℕ x + lemma11f {n} {x} n<m = begin + toℕ (fromℕ< (NatP.<-trans (toℕ<n x) n<m)) + ≡⟨ toℕ-fromℕ< _ ⟩ + toℕ x + ∎ where + open ≡-Reasoning + ISO.A←B iso (elm1 elm x) = fromℕ< x + ISO.B←A iso x = elm1 (FiniteSet.Q←F fa (fromℕ< (NatP.<-trans x<n n<m ))) to<n where + x<n : toℕ x < n + x<n = toℕ<n x + to<n : toℕ (FiniteSet.F←Q fa (FiniteSet.Q←F fa (fromℕ< (NatP.<-trans x<n n<m)))) < n + to<n = subst (λ k → toℕ k < n ) (sym (FiniteSet.finiso← fa _ )) (subst (λ k → k < n ) (sym ( toℕ-fromℕ< (NatP.<-trans x<n n<m) )) x<n ) + ISO.iso← iso x = lemma2 where + lemma2 : fromℕ< (subst (λ k → toℕ k < n) (sym + (FiniteSet.finiso← fa (fromℕ< (NatP.<-trans (toℕ<n x) n<m)))) (subst (λ k → k < n) + (sym (toℕ-fromℕ< (NatP.<-trans (toℕ<n x) n<m))) (toℕ<n x))) ≡ x + lemma2 = begin + fromℕ< (subst (λ k → toℕ k < n) (sym + (FiniteSet.finiso← fa (fromℕ< (NatP.<-trans (toℕ<n x) n<m)))) (subst (λ k → k < n) + (sym (toℕ-fromℕ< (NatP.<-trans (toℕ<n x) n<m))) (toℕ<n x))) + ≡⟨⟩ + fromℕ< ( subst (λ k → toℕ ( k ) < n ) (sym (FiniteSet.finiso← fa _ )) lemma6 ) + ≡⟨ lemma10 (cong (λ k → toℕ k) (FiniteSet.finiso← fa _ ) ) ⟩ + fromℕ< lemma6 + ≡⟨ lemma10 (lemma11 n<m ) ⟩ + fromℕ< ( toℕ<n x ) + ≡⟨ fromℕ<-toℕ _ _ ⟩ + x + ∎ where + open ≡-Reasoning + lemma6 : toℕ (fromℕ< (NatP.<-trans (toℕ<n x) n<m)) < n + lemma6 = subst ( λ k → k < n ) (sym (toℕ-fromℕ< (NatP.<-trans (toℕ<n x) n<m))) (toℕ<n x ) + ISO.iso→ iso (elm1 elm x) = fin-less-cong fa n<m _ _ lemma (lemma8 (cong (λ k → toℕ (FiniteSet.F←Q fa k) ) lemma ) ) where + lemma13 : toℕ (fromℕ< x) ≡ toℕ (FiniteSet.F←Q fa elm) + lemma13 = begin + toℕ (fromℕ< x) + ≡⟨ toℕ-fromℕ< _ ⟩ + toℕ (FiniteSet.F←Q fa elm) + ∎ where open ≡-Reasoning + lemma : FiniteSet.Q←F fa (fromℕ< (NatP.<-trans (toℕ<n (ISO.A←B iso (elm1 elm x))) n<m)) ≡ elm + lemma = begin + FiniteSet.Q←F fa (fromℕ< (NatP.<-trans (toℕ<n (ISO.A←B iso (elm1 elm x))) n<m)) + ≡⟨⟩ + FiniteSet.Q←F fa (fromℕ< ( NatP.<-trans (toℕ<n ( fromℕ< x ) ) n<m)) + ≡⟨ cong (λ k → FiniteSet.Q←F fa k) (lemma10 lemma13 ) ⟩ + FiniteSet.Q←F fa (fromℕ< ( NatP.<-trans x n<m)) + ≡⟨ cong (λ k → FiniteSet.Q←F fa (fromℕ< k )) {!!} ⟩ + FiniteSet.Q←F fa (fromℕ< ( toℕ<n (FiniteSet.F←Q fa elm))) + ≡⟨ cong (λ k → FiniteSet.Q←F fa k ) ( fromℕ<-toℕ _ _ ) ⟩ + FiniteSet.Q←F fa (FiniteSet.F←Q fa elm ) + ≡⟨ FiniteSet.finiso→ fa _ ⟩ + elm + ∎ where open ≡-Reasoning + +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/automaton-in-agda/src/flcagl.agda Sun Jun 13 20:45:17 2021 +0900 @@ -0,0 +1,481 @@ +open import Relation.Nullary +open import Relation.Binary.PropositionalEquality +module flcagl + (A : Set) + ( _≟_ : (a b : A) → Dec ( a ≡ b ) ) where + +open import Data.Bool hiding ( _≟_ ) +-- open import Data.Maybe +open import Level renaming ( zero to Zero ; suc to succ ) +open import Size + +module List where + + data List (i : Size) (A : Set) : Set where + [] : List i A + _∷_ : {j : Size< i} (x : A) (xs : List j A) → List i A + + + map : ∀{i A B} → (A → B) → List i A → List i B + map f [] = [] + map f ( x ∷ xs)= f x ∷ map f xs + + foldr : ∀{i} {A B : Set} → (A → B → B) → B → List i A → B + foldr c n [] = n + foldr c n (x ∷ xs) = c x (foldr c n xs) + + any : ∀{i A} → (A → Bool) → List i A → Bool + any p xs = foldr _∨_ false (map p xs) + +module Lang where + + open List + + record Lang (i : Size) : Set where + coinductive + field + ν : Bool + δ : ∀{j : Size< i} → A → Lang j + + open Lang + + _∋_ : ∀{i} → Lang i → List i A → Bool + l ∋ [] = ν l + l ∋ ( a ∷ as ) = δ l a ∋ as + + trie : ∀{i} (f : List i A → Bool) → Lang i + ν (trie f) = f [] + δ (trie f) a = trie (λ as → f (a ∷ as)) + + ∅ : ∀{i} → Lang i + ν ∅ = false + δ ∅ x = ∅ + + ε : ∀{i} → Lang i + ν ε = true + δ ε x = ∅ + + open import Relation.Nullary.Decidable + + char : ∀{i} (a : A) → Lang i + ν (char a) = false + δ (char a) x = if ⌊ a ≟ x ⌋ then ε else ∅ + + compl : ∀{i} (l : Lang i) → Lang i + ν (compl l) = not (ν l) + δ (compl l) x = compl (δ l x) + + + _∪_ : ∀{i} (k l : Lang i) → Lang i + ν (k ∪ l) = ν k ∨ ν l + δ (k ∪ l) x = δ k x ∪ δ l x + + + _·_ : ∀{i} (k l : Lang i) → Lang i + ν (k · l) = ν k ∧ ν l + δ (k · l) x = let k′l = δ k x · l in if ν k then k′l ∪ δ l x else k′l + + _*_ : ∀{i} (k l : Lang i ) → Lang i + ν (k * l) = ν k ∧ ν l + δ (_*_ {i} k l) {j} x = + let + k′l : Lang j + k′l = _*_ {j} (δ k {j} x) l + in if ν k then _∪_ {j} k′l (δ l {j} x) else k′l + + _* : ∀{i} (l : Lang i) → Lang i + ν (l *) = true + δ (l *) x = δ l x · (l *) + + record _≅⟨_⟩≅_ (l : Lang ∞ ) i (k : Lang ∞) : Set where + coinductive + field ≅ν : ν l ≡ ν k + ≅δ : ∀ {j : Size< i } (a : A ) → δ l a ≅⟨ j ⟩≅ δ k a + + open _≅⟨_⟩≅_ + + ≅refl : ∀{i} {l : Lang ∞} → l ≅⟨ i ⟩≅ l + ≅ν ≅refl = refl + ≅δ ≅refl a = ≅refl + + + ≅sym : ∀{i} {k l : Lang ∞} (p : l ≅⟨ i ⟩≅ k) → k ≅⟨ i ⟩≅ l + ≅ν (≅sym p) = sym (≅ν p) + ≅δ (≅sym p) a = ≅sym (≅δ p a) + + ≅trans : ∀{i} {k l m : Lang ∞} + ( p : k ≅⟨ i ⟩≅ l ) ( q : l ≅⟨ i ⟩≅ m ) → k ≅⟨ i ⟩≅ m + ≅ν (≅trans p q) = trans (≅ν p) (≅ν q) + ≅δ (≅trans p q) a = ≅trans (≅δ p a) (≅δ q a) + + open import Relation.Binary + + ≅isEquivalence : ∀(i : Size) → IsEquivalence _≅⟨ i ⟩≅_ + ≅isEquivalence i = record { refl = ≅refl; sym = ≅sym; trans = ≅trans } + + Bis : ∀(i : Size) → Setoid _ _ + Setoid.Carrier (Bis i) = Lang ∞ + Setoid._≈_ (Bis i) = _≅⟨ i ⟩≅_ + Setoid.isEquivalence (Bis i) = ≅isEquivalence i + + import Relation.Binary.EqReasoning as EqR + + ≅trans′ : ∀ i (k l m : Lang ∞) + ( p : k ≅⟨ i ⟩≅ l ) ( q : l ≅⟨ i ⟩≅ m ) → k ≅⟨ i ⟩≅ m + ≅trans′ i k l m p q = begin + k ≈⟨ p ⟩ + l ≈⟨ q ⟩ + m ∎ where open EqR (Bis i) + + open import Data.Bool.Properties + + union-assoc : ∀{i} (k {l m} : Lang ∞) → ((k ∪ l) ∪ m ) ≅⟨ i ⟩≅ ( k ∪ (l ∪ m) ) + ≅ν (union-assoc k) = ∨-assoc (ν k) _ _ + ≅δ (union-assoc k) a = union-assoc (δ k a) + union-comm : ∀{i} (l k : Lang ∞) → (l ∪ k ) ≅⟨ i ⟩≅ ( k ∪ l ) + ≅ν (union-comm l k) = ∨-comm (ν l) _ + ≅δ (union-comm l k) a = union-comm (δ l a) (δ k a) + union-idem : ∀{i} (l : Lang ∞) → (l ∪ l ) ≅⟨ i ⟩≅ l + ≅ν (union-idem l) = ∨-idem _ + ≅δ (union-idem l) a = union-idem (δ l a) + union-emptyl : ∀{i}{l : Lang ∞} → (∅ ∪ l ) ≅⟨ i ⟩≅ l + ≅ν union-emptyl = refl + ≅δ union-emptyl a = union-emptyl + + union-cong : ∀{i}{k k′ l l′ : Lang ∞} + (p : k ≅⟨ i ⟩≅ k′) (q : l ≅⟨ i ⟩≅ l′ ) → ( k ∪ l ) ≅⟨ i ⟩≅ ( k′ ∪ l′ ) + ≅ν (union-cong p q) = cong₂ _∨_ (≅ν p) (≅ν q) + ≅δ (union-cong p q) a = union-cong (≅δ p a) (≅δ q a) + + withExample : (P : Bool → Set) (p : P true) (q : P false) → + {A : Set} (g : A → Bool) (x : A) → P (g x) + withExample P p q g x with g x + ... | true = p + ... | false = q + + rewriteExample : {A : Set} {P : A → Set} {x : A} (p : P x) + {g : A → A} (e : g x ≡ x) → P (g x) + rewriteExample p e rewrite e = p + + infixr 6 _∪_ + infixr 7 _·_ + infix 5 _≅⟨_⟩≅_ + + union-congl : ∀{i}{k k′ l : Lang ∞} + (p : k ≅⟨ i ⟩≅ k′) → ( k ∪ l ) ≅⟨ i ⟩≅ ( k′ ∪ l ) + union-congl eq = union-cong eq ≅refl + + union-congr : ∀{i}{k l l′ : Lang ∞} + (p : l ≅⟨ i ⟩≅ l′) → ( k ∪ l ) ≅⟨ i ⟩≅ ( k ∪ l′ ) + union-congr eq = union-cong ≅refl eq + + union-swap24 : ∀{i} ({x y z w} : Lang ∞) → (x ∪ y) ∪ z ∪ w + ≅⟨ i ⟩≅ (x ∪ z) ∪ y ∪ w + union-swap24 {_} {x} {y} {z} {w} = begin + (x ∪ y) ∪ z ∪ w + ≈⟨ union-assoc x ⟩ + x ∪ y ∪ z ∪ w + ≈⟨ union-congr (≅sym ( union-assoc y)) ⟩ + x ∪ ((y ∪ z) ∪ w) + ≈⟨ ≅sym ( union-assoc x ) ⟩ + (x ∪ ( y ∪ z)) ∪ w + ≈⟨ union-congl (union-congr (union-comm y z )) ⟩ + ( x ∪ (z ∪ y)) ∪ w + ≈⟨ union-congl (≅sym ( union-assoc x )) ⟩ + ((x ∪ z) ∪ y) ∪ w + ≈⟨ union-assoc (x ∪ z) ⟩ + (x ∪ z) ∪ y ∪ w + ∎ + where open EqR (Bis _) + + concat-union-distribr : ∀{i} (k {l m} : Lang ∞) → k · ( l ∪ m ) ≅⟨ i ⟩≅ ( k · l ) ∪ ( k · m ) + ≅ν (concat-union-distribr k) = ∧-distribˡ-∨ (ν k) _ _ + ≅δ (concat-union-distribr k) a with ν k + ≅δ (concat-union-distribr k {l} {m}) a | true = begin + δ k a · (l ∪ m) ∪ (δ l a ∪ δ m a) + ≈⟨ union-congl (concat-union-distribr _) ⟩ + (δ k a · l ∪ δ k a · m) ∪ (δ l a ∪ δ m a) + ≈⟨ union-swap24 ⟩ + (δ k a · l ∪ δ l a) ∪ (δ k a · m ∪ δ m a) + ∎ + where open EqR (Bis _) + ≅δ (concat-union-distribr k) a | false = concat-union-distribr (δ k a) + + concat-union-distribl : ∀{i} (k {l m} : Lang ∞) → ( k ∪ l ) · m ≅⟨ i ⟩≅ ( k · m ) ∪ ( l · m ) + ≅ν (concat-union-distribl k {l} {m}) = ∧-distribʳ-∨ _ (ν k) _ + ≅δ (concat-union-distribl k {l} {m}) a with ν k | ν l + ≅δ (concat-union-distribl k {l} {m}) a | false | false = concat-union-distribl (δ k a) + ≅δ (concat-union-distribl k {l} {m}) a | false | true = begin + (if false ∨ true then (δ k a ∪ δ l a) · m ∪ δ m a else (δ k a ∪ δ l a) · m) + ≈⟨ ≅refl ⟩ + ((δ k a ∪ δ l a) · m ) ∪ δ m a + ≈⟨ union-congl (concat-union-distribl _) ⟩ + (δ k a · m ∪ δ l a · m) ∪ δ m a + ≈⟨ union-assoc _ ⟩ + (δ k a · m) ∪ ( δ l a · m ∪ δ m a ) + ≈⟨ ≅refl ⟩ + (if false then δ k a · m ∪ δ m a else δ k a · m) ∪ (if true then δ l a · m ∪ δ m a else δ l a · m) + ∎ + where open EqR (Bis _) + ≅δ (concat-union-distribl k {l} {m}) a | true | false = begin + (if true ∨ false then (δ k a ∪ δ l a) · m ∪ δ m a else (δ k a ∪ δ l a) · m) ≈⟨ ≅refl ⟩ + ((δ k a ∪ δ l a) · m ) ∪ δ m a ≈⟨ union-congl (concat-union-distribl _) ⟩ + (δ k a · m ∪ δ l a · m) ∪ δ m a ≈⟨ union-assoc _ ⟩ + δ k a · m ∪ ( δ l a · m ∪ δ m a ) ≈⟨ union-congr ( union-comm _ _) ⟩ + δ k a · m ∪ δ m a ∪ δ l a · m ≈⟨ ≅sym ( union-assoc _ ) ⟩ + (δ k a · m ∪ δ m a) ∪ δ l a · m ≈⟨ ≅refl ⟩ + ((if true then δ k a · m ∪ δ m a else δ k a · m) ∪ (if false then δ l a · m ∪ δ m a else δ l a · m)) + ∎ + where open EqR (Bis _) + ≅δ (concat-union-distribl k {l} {m}) a | true | true = begin + (if true ∨ true then (δ k a ∪ δ l a) · m ∪ δ m a else (δ k a ∪ δ l a) · m) ≈⟨ ≅refl ⟩ + (δ k a ∪ δ l a) · m ∪ δ m a ≈⟨ union-congl ( concat-union-distribl _ ) ⟩ + (δ k a · m ∪ δ l a · m) ∪ δ m a ≈⟨ union-assoc _ ⟩ + δ k a · m ∪ ( δ l a · m ∪ δ m a ) ≈⟨ ≅sym ( union-congr ( union-congr ( union-idem _ ) ) ) ⟩ + δ k a · m ∪ ( δ l a · m ∪ (δ m a ∪ δ m a) ) ≈⟨ ≅sym ( union-congr ( union-assoc _ )) ⟩ + δ k a · m ∪ ( (δ l a · m ∪ δ m a ) ∪ δ m a ) ≈⟨ union-congr ( union-congl ( union-comm _ _) ) ⟩ + δ k a · m ∪ ( (δ m a ∪ δ l a · m ) ∪ δ m a ) ≈⟨ ≅sym ( union-assoc _ ) ⟩ + ( δ k a · m ∪ (δ m a ∪ δ l a · m )) ∪ δ m a ≈⟨ ≅sym ( union-congl ( union-assoc _ ) ) ⟩ + ((δ k a · m ∪ δ m a) ∪ δ l a · m) ∪ δ m a ≈⟨ union-assoc _ ⟩ + (δ k a · m ∪ δ m a) ∪ δ l a · m ∪ δ m a ≈⟨ ≅refl ⟩ + ((if true then δ k a · m ∪ δ m a else δ k a · m) ∪ (if true then δ l a · m ∪ δ m a else δ l a · m)) + ∎ + where open EqR (Bis _) + + postulate + concat-emptyl : ∀{i} l → ∅ · l ≅⟨ i ⟩≅ ∅ + concat-emptyr : ∀{i} l → l · ∅ ≅⟨ i ⟩≅ ∅ + concat-unitl : ∀{i} l → ε · l ≅⟨ i ⟩≅ l + concat-unitr : ∀{i} l → l · ε ≅⟨ i ⟩≅ l + star-empty : ∀{i} → ∅ * ≅⟨ i ⟩≅ ε + + concat-congl : ∀{i} {m l k : Lang ∞} → l ≅⟨ i ⟩≅ k → l · m ≅⟨ i ⟩≅ k · m + ≅ν (concat-congl {i} {m} p ) = cong (λ x → x ∧ ( ν m )) ( ≅ν p ) + ≅δ (concat-congl {i} {m} {l} {k} p ) a with ν k | ν l | ≅ν p + ≅δ (concat-congl {i} {m} {l} {k} p) a | false | false | refl = concat-congl (≅δ p a) + ≅δ (concat-congl {i} {m} {l} {k} p) a | true | true | refl = union-congl (concat-congl (≅δ p a)) + + concat-congr : ∀{i} {m l k : Lang ∞} → l ≅⟨ i ⟩≅ k → m · l ≅⟨ i ⟩≅ m · k + ≅ν (concat-congr {i} {m} {_} {k} p ) = cong (λ x → ( ν m ) ∧ x ) ( ≅ν p ) + ≅δ (concat-congr {i} {m} {l} {k} p ) a with ν m | ν k | ν l | ≅ν p + ≅δ (concat-congr {i} {m} {l} {k} p) a | false | x | .x | refl = concat-congr p + ≅δ (concat-congr {i} {m} {l} {k} p) a | true | x | .x | refl = union-cong (concat-congr p ) ( ≅δ p a ) + + concat-assoc : ∀{i} (k {l m} : Lang ∞) → (k · l) · m ≅⟨ i ⟩≅ k · (l · m) + ≅ν (concat-assoc {i} k {l} {m} ) = ∧-assoc ( ν k ) ( ν l ) ( ν m ) + ≅δ (concat-assoc {i} k {l} {m} ) a with ν k + ≅δ (concat-assoc {i} k {l} {m}) a | false = concat-assoc _ + ≅δ (concat-assoc {i} k {l} {m}) a | true with ν l + ≅δ (concat-assoc {i} k {l} {m}) a | true | false = begin + ( if false then (δ k a · l ∪ δ l a) · m ∪ δ m a else (δ k a · l ∪ δ l a) · m ) + ≈⟨ ≅refl ⟩ + (δ k a · l ∪ δ l a) · m + ≈⟨ concat-union-distribl _ ⟩ + ((δ k a · l) · m ) ∪ ( δ l a · m ) + ≈⟨ union-congl (concat-assoc _) ⟩ + (δ k a · l · m ) ∪ ( δ l a · m ) + ≈⟨ ≅refl ⟩ + δ k a · l · m ∪ (if false then δ l a · m ∪ δ m a else δ l a · m) + ∎ where open EqR (Bis _) + ≅δ (concat-assoc {i} k {l} {m}) a | true | true = begin + (if true then (δ k a · l ∪ δ l a) · m ∪ δ m a else (δ k a · l ∪ δ l a) · m) + ≈⟨ ≅refl ⟩ + ((( δ k a · l ) ∪ δ l a) · m ) ∪ δ m a + ≈⟨ union-congl (concat-union-distribl _ ) ⟩ + ((δ k a · l) · m ∪ ( δ l a · m )) ∪ δ m a + ≈⟨ union-congl ( union-congl (concat-assoc _)) ⟩ + (( δ k a · l · m ) ∪ ( δ l a · m )) ∪ δ m a + ≈⟨ union-assoc _ ⟩ + ( δ k a · l · m ) ∪ ( ( δ l a · m ) ∪ δ m a ) + ≈⟨ ≅refl ⟩ + δ k a · l · m ∪ (if true then δ l a · m ∪ δ m a else δ l a · m) + ∎ where open EqR (Bis _) + + star-concat-idem : ∀{i} (l : Lang ∞) → l * · l * ≅⟨ i ⟩≅ l * + ≅ν (star-concat-idem l) = refl + ≅δ (star-concat-idem l) a = begin + δ ((l *) · (l *)) a ≈⟨ union-congl (concat-assoc _) ⟩ + δ l a · (l * · l *) ∪ δ l a · l * ≈⟨ union-congl (concat-congr (star-concat-idem _)) ⟩ + δ l a · l * ∪ δ l a · l * ≈⟨ union-idem _ ⟩ + δ (l *) a ∎ where open EqR (Bis _) + + star-idem : ∀{i} (l : Lang ∞) → (l *) * ≅⟨ i ⟩≅ l * + ≅ν (star-idem l) = refl + ≅δ (star-idem l) a = begin + δ ((l *) *) a ≈⟨ concat-assoc (δ l a) ⟩ + δ l a · ((l *) · ((l *) *)) ≈⟨ concat-congr ( concat-congr (star-idem l )) ⟩ + δ l a · ((l *) · (l *)) ≈⟨ concat-congr (star-concat-idem l ) ⟩ + δ l a · l * + ∎ where open EqR (Bis _) + + postulate + star-rec : ∀{i} (l : Lang ∞) → l * ≅⟨ i ⟩≅ ε ∪ (l · l *) + + star-from-rec : ∀{i} (k {l m} : Lang ∞) + → ν k ≡ false + → l ≅⟨ i ⟩≅ k · l ∪ m + → l ≅⟨ i ⟩≅ k * · m + ≅ν (star-from-rec k n p) with ≅ν p + ... | b rewrite n = b + ≅δ (star-from-rec k {l} {m} n p) a with ≅δ p a + ... | q rewrite n = begin + (δ l a) + ≈⟨ q ⟩ + δ k a · l ∪ δ m a + ≈⟨ union-congl (concat-congr (star-from-rec k {l} {m} n p)) ⟩ + (δ k a · (k * · m) ∪ δ m a) + ≈⟨ union-congl (≅sym (concat-assoc _)) ⟩ + (δ k a · (k *)) · m ∪ δ m a + ∎ where open EqR (Bis _) + + +open List + +record DA (S : Set) : Set where + field ν : (s : S) → Bool + δ : (s : S)(a : A) → S + νs : ∀{i} (ss : List.List i S) → Bool + νs ss = List.any ν ss + δs : ∀{i} (ss : List.List i S) (a : A) → List.List i S + δs ss a = List.map (λ s → δ s a) ss + +open Lang + +lang : ∀{i} {S} (da : DA S) (s : S) → Lang i +Lang.ν (lang da s) = DA.ν da s +Lang.δ (lang da s) a = lang da (DA.δ da s a) + +open import Data.Unit hiding ( _≟_ ) + +open DA + +∅A : DA ⊤ +ν ∅A s = false +δ ∅A s a = s + +εA : DA Bool +ν εA b = b +δ εA b a = false + +open import Relation.Nullary.Decidable + +data 3States : Set where + init acc err : 3States + +charA : (a : A) → DA 3States +ν (charA a) init = false +ν (charA a) acc = true +ν (charA a) err = false +δ (charA a) init x = + if ⌊ a ≟ x ⌋ then acc else err +δ (charA a) acc x = err +δ (charA a) err x = err + + +complA : ∀{S} (da : DA S) → DA S +ν (complA da) s = not (ν da s) +δ (complA da) s a = δ da s a + +open import Data.Product + +_⊕_ : ∀{S1 S2} (da1 : DA S1) (da2 : DA S2) → DA (S1 × S2) +ν (da1 ⊕ da2) (s1 , s2) = ν da1 s1 ∨ ν da2 s2 +δ (da1 ⊕ da2) (s1 , s2) a = δ da1 s1 a , δ da2 s2 a + +powA : ∀{S} (da : DA S) → DA (List ∞ S) +ν (powA da) ss = νs da ss +δ (powA da) ss a = δs da ss a + +open _≅⟨_⟩≅_ + +powA-nil : ∀{i S} (da : DA S) → lang (powA da) [] ≅⟨ i ⟩≅ ∅ +≅ν (powA-nil da) = refl +≅δ (powA-nil da) a = powA-nil da + +powA-cons : ∀{i S} (da : DA S) {s : S} {ss : List ∞ S} → + lang (powA da) (s ∷ ss) ≅⟨ i ⟩≅ lang da s ∪ lang (powA da) ss +≅ν (powA-cons da) = refl +≅δ (powA-cons da) a = powA-cons da + +composeA : ∀{S1 S2} (da1 : DA S1)(s2 : S2)(da2 : DA S2) → DA (S1 × List ∞ S2) +ν (composeA da1 s2 da2) (s1 , ss2) = (ν da1 s1 ∧ ν da2 s2) ∨ νs da2 ss2 +δ (composeA da1 s2 da2) (s1 , ss2) a = + δ da1 s1 a , δs da2 (if ν da1 s1 then s2 ∷ ss2 else ss2) a + +import Relation.Binary.EqReasoning as EqR + +composeA-gen : ∀{i S1 S2} (da1 : DA S1) (da2 : DA S2) → ∀(s1 : S1)(s2 : S2)(ss : List ∞ S2) → + lang (composeA da1 s2 da2) (s1 , ss) ≅⟨ i ⟩≅ lang da1 s1 · lang da2 s2 ∪ lang (powA da2) ss +≅ν (composeA-gen da1 da2 s1 s2 ss) = refl +≅δ (composeA-gen da1 da2 s1 s2 ss) a with ν da1 s1 +... | false = composeA-gen da1 da2 (δ da1 s1 a) s2 (δs da2 ss a) +... | true = begin + lang (composeA da1 s2 da2) (δ da1 s1 a , δ da2 s2 a ∷ δs da2 ss a) + ≈⟨ composeA-gen da1 da2 (δ da1 s1 a) s2 (δs da2 (s2 ∷ ss) a) ⟩ + lang da1 (δ da1 s1 a) · lang da2 s2 ∪ lang (powA da2) (δs da2 (s2 ∷ ss) a) + ≈⟨ union-congr (powA-cons da2) ⟩ + lang da1 (δ da1 s1 a) · lang da2 s2 ∪ + (lang da2 (δ da2 s2 a) ∪ lang (powA da2) (δs da2 ss a)) + ≈⟨ ≅sym (union-assoc _) ⟩ + (lang da1 (δ da1 s1 a) · lang da2 s2 ∪ lang da2 (δ da2 s2 a)) ∪ lang (powA da2) (δs da2 ss a) + ∎ where open EqR (Bis _) + +postulate + composeA-correct : ∀{i S1 S2} (da1 : DA S1) (da2 : DA S2) s1 s2 → + lang (composeA da1 s2 da2) (s1 , []) ≅⟨ i ⟩≅ lang da1 s1 · lang da2 s2 + + +open import Data.Maybe + +acceptingInitial : ∀{S} (s0 : S) (da : DA S) → DA (Maybe S) +ν (acceptingInitial s0 da) (just s) = ν da s +δ (acceptingInitial s0 da) (just s) a = just (δ da s a) +ν (acceptingInitial s0 da) nothing = true +δ (acceptingInitial s0 da) nothing a = just (δ da s0 a) + + + +finalToInitial : ∀{S} (da : DA (Maybe S)) → DA (List ∞ (Maybe S)) +ν (finalToInitial da) ss = νs da ss +δ (finalToInitial da) ss a = + let ss′ = δs da ss a + in if νs da ss then δ da nothing a ∷ ss′ else ss′ + + +starA : ∀{S}(s0 : S)(da : DA S) → DA (List ∞(Maybe S)) +starA s0 da = finalToInitial (acceptingInitial s0 da) + + +postulate + acceptingInitial-just : ∀{i S} (s0 : S) (da : DA S) {s : S} → + lang (acceptingInitial s0 da) (just s) ≅⟨ i ⟩≅ lang da s + acceptingInitial-nothing : ∀{i S} (s0 : S) (da : DA S) → + lang (acceptingInitial s0 da) nothing ≅⟨ i ⟩≅ ε ∪ lang da s0 + starA-lemma : ∀{i S}(da : DA S)(s0 : S)(ss : List ∞ (Maybe S))→ + lang (starA s0 da) ss ≅⟨ i ⟩≅ + lang (powA (acceptingInitial s0 da)) ss · (lang da s0) * + starA-correct : ∀{i S} (da : DA S) (s0 : S) → + lang (starA s0 da) (nothing ∷ []) ≅⟨ i ⟩≅ (lang da s0) * + +record NAutomaton ( Q : Set ) ( Σ : Set ) + : Set where + field + Nδ : Q → Σ → Q → Bool + Nstart : Q → Bool + Nend : Q → Bool + +postulate + exists : { S : Set} → ( S → Bool ) → Bool + +nlang : ∀{i} {S} (nfa : NAutomaton S A ) (s : S → Bool ) → Lang i +Lang.ν (nlang nfa s) = exists ( λ x → (s x ∧ NAutomaton.Nend nfa x )) +Lang.δ (nlang nfa s) a = nlang nfa (λ x → s x ∧ (NAutomaton.Nδ nfa x a) x) + +nlang1 : ∀{i} {S} (nfa : NAutomaton S A ) (s : S → Bool ) → Lang i +Lang.ν (nlang1 nfa s) = NAutomaton.Nend nfa {!!} +Lang.δ (nlang1 nfa s) a = nlang1 nfa (λ x → s x ∧ (NAutomaton.Nδ nfa x a) x) + +-- nlang' : ∀{i} {S} (nfa : DA (S → Bool) ) (s : S → Bool ) → Lang i +-- Lang.ν (nlang' nfa s) = DA.ν nfa s +-- Lang.δ (nlang' nfa s) a = nlang' nfa (DA.δ nfa s a) +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/automaton-in-agda/src/gcd.agda Sun Jun 13 20:45:17 2021 +0900 @@ -0,0 +1,217 @@ +{-# OPTIONS --allow-unsolved-metas #-} +module gcd where + +open import Data.Nat +open import Data.Nat.Properties +open import Data.Empty +open import Data.Unit using (⊤ ; tt) +open import Relation.Nullary +open import Relation.Binary.PropositionalEquality +open import Relation.Binary.Definitions +open import nat +open import logic + +record Factor (n m : ℕ ) : Set where + field + factor : ℕ + remain : ℕ + is-factor : factor * n + remain ≡ m + +record Dividable (n m : ℕ ) : Set where + field + factor : ℕ + is-factor : factor * n + 0 ≡ m + +open Factor + +open ≡-Reasoning + +decf : { n k : ℕ } → ( x : Factor k (suc n) ) → Factor k n +decf {n} {k} x with remain x +... | zero = record { factor = factor x ; remain = k ; is-factor = {!!} } +... | suc r = record { factor = factor x ; remain = r ; is-factor = {!!} } + +ifk0 : ( i0 k : ℕ ) → (i0f : Factor k i0 ) → ( i0=0 : remain i0f ≡ 0 ) → factor i0f * k + 0 ≡ i0 +ifk0 i0 k i0f i0=0 = begin + factor i0f * k + 0 ≡⟨ cong (λ m → factor i0f * k + m) (sym i0=0) ⟩ + factor i0f * k + remain i0f ≡⟨ is-factor i0f ⟩ + i0 ∎ + +ifzero : {k : ℕ } → (jf : Factor k zero ) → remain jf ≡ 0 +ifzero = {!!} + +gcd1 : ( i i0 j j0 : ℕ ) → ℕ +gcd1 zero i0 zero j0 with <-cmp i0 j0 +... | tri< a ¬b ¬c = i0 +... | tri≈ ¬a refl ¬c = i0 +... | tri> ¬a ¬b c = j0 +gcd1 zero i0 (suc zero) j0 = 1 +gcd1 zero zero (suc (suc j)) j0 = j0 +gcd1 zero (suc i0) (suc (suc j)) j0 = gcd1 i0 (suc i0) (suc j) (suc (suc j)) +gcd1 (suc zero) i0 zero j0 = 1 +gcd1 (suc (suc i)) i0 zero zero = i0 +gcd1 (suc (suc i)) i0 zero (suc j0) = gcd1 (suc i) (suc (suc i)) j0 (suc j0) +gcd1 (suc i) i0 (suc j) j0 = gcd1 i i0 j j0 + +gcd : ( i j : ℕ ) → ℕ +gcd i j = gcd1 i i j j + +gcd-gt : ( i i0 j j0 k : ℕ ) → (if : Factor k i) (i0f : Factor k i0 ) (jf : Factor k i ) (j0f : Factor k j0) + → remain i0f ≡ 0 → remain j0f ≡ 0 + → (remain if + i ) ≡ i0 → (remain jf + j ) ≡ j0 + → Dividable k ( gcd1 i i0 j j0 ) +gcd-gt zero i0 zero j0 k if i0f jf j0f i0=0 j0=0 ir=i0 jr=j0 with <-cmp i0 j0 +... | tri< a ¬b ¬c = record { factor = factor i0f ; is-factor = ifk0 i0 k i0f i0=0 } +... | tri≈ ¬a refl ¬c = record { factor = factor i0f ; is-factor = ifk0 i0 k i0f i0=0 } +... | tri> ¬a ¬b c = record { factor = factor j0f ; is-factor = ifk0 j0 k j0f j0=0 } +gcd-gt zero i0 (suc zero) j0 k if i0f jf j0f i0=0 j0=0 ir=i0 jr=j0 = {!!} -- can't happen +gcd-gt zero zero (suc (suc j)) j0 k if i0f jf j0f i0=0 j0=0 ir=i0 jr=j0 = record { factor = factor j0f ; is-factor = ifk0 j0 k j0f j0=0 } +gcd-gt zero (suc i0) (suc (suc j)) j0 k if i0f jf j0f i0=0 j0=0 ir=i0 jr=j0 = + gcd-gt i0 (suc i0) (suc j) (suc (suc j)) k (decf i0f) i0f (decf i0f) + record { factor = factor jf ; remain = remain jf ; is-factor = {!!} } i0=0 {!!} {!!} {!!} +gcd-gt (suc zero) i0 zero j0 k if i0f jf j0f i0=0 j0=0 ir=i0 jr=j0 = {!!} -- can't happen +gcd-gt (suc (suc i)) i0 zero zero k if i0f jf j0f i0=0 j0=0 ir=i0 jr=j0 = {!!} +gcd-gt (suc (suc i)) i0 zero (suc j0) k if i0f jf j0f i0=0 j0=0 ir=i0 jr=j0 = + gcd-gt (suc i) (suc (suc i)) j0 (suc j0) k (decf if) {!!} (decf jf) j0f j0=0 {!!} {!!} {!!} +gcd-gt (suc zero) i0 (suc j) j0 k if i0f jf j0f i0=0 j0=0 ir=i0 jr=j0 = + gcd-gt zero i0 j j0 k (decf if) i0f (decf jf) j0f i0=0 j0=0 {!!} {!!} +gcd-gt (suc (suc i)) i0 (suc j) j0 k if i0f jf j0f i0=0 j0=0 ir=i0 jr=j0 = + gcd-gt (suc i) i0 j j0 k (decf if) i0f (decf jf) j0f i0=0 j0=0 {!!} {!!} + +-- gcd26 : { n m : ℕ} → n > 1 → m > 1 → n - m > 0 → gcd n m ≡ gcd (n - m) m +-- gcd27 : { n m : ℕ} → n > 1 → m > 1 → n - m > 0 → gcd n k ≡ k → k ≤ n + +gcd22 : ( i i0 o o0 : ℕ ) → gcd1 (suc i) i0 (suc o) o0 ≡ gcd1 i i0 o o0 +gcd22 zero i0 zero o0 = refl +gcd22 zero i0 (suc o) o0 = refl +gcd22 (suc i) i0 zero o0 = refl +gcd22 (suc i) i0 (suc o) o0 = refl + +gcd20 : (i : ℕ) → gcd i 0 ≡ i +gcd20 zero = refl +gcd20 (suc i) = gcd201 (suc i) where + gcd201 : (i : ℕ ) → gcd1 i i zero zero ≡ i + gcd201 zero = refl + gcd201 (suc zero) = refl + gcd201 (suc (suc i)) = refl + +gcdmm : (n m : ℕ) → gcd1 n m n m ≡ m +gcdmm zero m with <-cmp m m +... | tri< a ¬b ¬c = refl +... | tri≈ ¬a refl ¬c = refl +... | tri> ¬a ¬b c = refl +gcdmm (suc n) m = subst (λ k → k ≡ m) (sym (gcd22 n m n m )) (gcdmm n m ) + +gcdsym2 : (i j : ℕ) → gcd1 zero i zero j ≡ gcd1 zero j zero i +gcdsym2 i j with <-cmp i j | <-cmp j i +... | tri< a ¬b ¬c | tri< a₁ ¬b₁ ¬c₁ = ⊥-elim (nat-<> a a₁) +... | tri< a ¬b ¬c | tri≈ ¬a b ¬c₁ = ⊥-elim (nat-≡< (sym b) a) +... | tri< a ¬b ¬c | tri> ¬a ¬b₁ c = refl +... | tri≈ ¬a b ¬c | tri< a ¬b ¬c₁ = ⊥-elim (nat-≡< (sym b) a) +... | tri≈ ¬a refl ¬c | tri≈ ¬a₁ refl ¬c₁ = refl +... | tri≈ ¬a b ¬c | tri> ¬a₁ ¬b c = ⊥-elim (nat-≡< b c) +... | tri> ¬a ¬b c | tri< a ¬b₁ ¬c = refl +... | tri> ¬a ¬b c | tri≈ ¬a₁ b ¬c = ⊥-elim (nat-≡< b c) +... | tri> ¬a ¬b c | tri> ¬a₁ ¬b₁ c₁ = ⊥-elim (nat-<> c c₁) +gcdsym1 : ( i i0 j j0 : ℕ ) → gcd1 i i0 j j0 ≡ gcd1 j j0 i i0 +gcdsym1 zero zero zero zero = refl +gcdsym1 zero zero zero (suc j0) = refl +gcdsym1 zero (suc i0) zero zero = refl +gcdsym1 zero (suc i0) zero (suc j0) = gcdsym2 (suc i0) (suc j0) +gcdsym1 zero zero (suc zero) j0 = refl +gcdsym1 zero zero (suc (suc j)) j0 = refl +gcdsym1 zero (suc i0) (suc zero) j0 = refl +gcdsym1 zero (suc i0) (suc (suc j)) j0 = gcdsym1 i0 (suc i0) (suc j) (suc (suc j)) +gcdsym1 (suc zero) i0 zero j0 = refl +gcdsym1 (suc (suc i)) i0 zero zero = refl +gcdsym1 (suc (suc i)) i0 zero (suc j0) = gcdsym1 (suc i) (suc (suc i))j0 (suc j0) +gcdsym1 (suc i) i0 (suc j) j0 = subst₂ (λ j k → j ≡ k ) (sym (gcd22 i _ _ _)) (sym (gcd22 j _ _ _)) (gcdsym1 i i0 j j0 ) + +gcdsym : { n m : ℕ} → gcd n m ≡ gcd m n +gcdsym {n} {m} = gcdsym1 n n m m + +gcd11 : ( i : ℕ ) → gcd i i ≡ i +gcd11 i = gcdmm i i + +gcd203 : (i : ℕ) → gcd1 (suc i) (suc i) i i ≡ 1 +gcd203 zero = refl +gcd203 (suc i) = gcd205 (suc i) where + gcd205 : (j : ℕ) → gcd1 (suc j) (suc (suc i)) j (suc i) ≡ 1 + gcd205 zero = refl + gcd205 (suc j) = subst (λ k → k ≡ 1) (gcd22 (suc j) (suc (suc i)) j (suc i)) (gcd205 j) +gcd204 : (i : ℕ) → gcd1 1 1 i i ≡ 1 +gcd204 zero = refl +gcd204 (suc zero) = refl +gcd204 (suc (suc zero)) = refl +gcd204 (suc (suc (suc i))) = gcd204 (suc (suc i)) + +gcd2 : ( i j : ℕ ) → gcd (i + j) j ≡ gcd i j +gcd2 i j = gcd200 i i j j refl refl where + gcd202 : (i j1 : ℕ) → (i + suc j1) ≡ suc (i + j1) + gcd202 zero j1 = refl + gcd202 (suc i) j1 = cong suc (gcd202 i j1) + gcd201 : (i i0 j j0 j1 : ℕ) → gcd1 (i + j1) (i0 + suc j) j1 j0 ≡ gcd1 i (i0 + suc j) zero j0 + gcd201 i i0 j j0 zero = subst (λ k → gcd1 k (i0 + suc j) zero j0 ≡ gcd1 i (i0 + suc j) zero j0 ) (+-comm zero i) refl + gcd201 i i0 j j0 (suc j1) = begin + gcd1 (i + suc j1) (i0 + suc j) (suc j1) j0 ≡⟨ cong (λ k → gcd1 k (i0 + suc j) (suc j1) j0 ) (gcd202 i j1) ⟩ + gcd1 (suc (i + j1)) (i0 + suc j) (suc j1) j0 ≡⟨ gcd22 (i + j1) (i0 + suc j) j1 j0 ⟩ + gcd1 (i + j1) (i0 + suc j) j1 j0 ≡⟨ gcd201 i i0 j j0 j1 ⟩ + gcd1 i (i0 + suc j) zero j0 ∎ where open ≡-Reasoning + gcd200 : (i i0 j j0 : ℕ) → i ≡ i0 → j ≡ j0 → gcd1 (i + j) (i0 + j) j j0 ≡ gcd1 i i j0 j0 + gcd200 i .i zero .0 refl refl = subst (λ k → gcd1 k k zero zero ≡ gcd1 i i zero zero ) (+-comm zero i) refl + gcd200 (suc (suc i)) i0 (suc j) (suc j0) i=i0 j=j0 = gcd201 (suc (suc i)) i0 j (suc j0) (suc j) + gcd200 zero zero (suc zero) .1 i=i0 refl = refl + gcd200 zero zero (suc (suc j)) .(suc (suc j)) i=i0 refl = begin + gcd1 (zero + suc (suc j)) (zero + suc (suc j)) (suc (suc j)) (suc (suc j)) ≡⟨ gcdmm (suc (suc j)) (suc (suc j)) ⟩ + suc (suc j) ≡⟨ sym (gcd20 (suc (suc j))) ⟩ + gcd1 zero zero (suc (suc j)) (suc (suc j)) ∎ where open ≡-Reasoning + gcd200 zero (suc i0) (suc j) .(suc j) () refl + gcd200 (suc zero) .1 (suc j) .(suc j) refl refl = begin + gcd1 (1 + suc j) (1 + suc j) (suc j) (suc j) ≡⟨ gcd203 (suc j) ⟩ + 1 ≡⟨ sym ( gcd204 (suc j)) ⟩ + gcd1 1 1 (suc j) (suc j) ∎ where open ≡-Reasoning + gcd200 (suc (suc i)) i0 (suc j) zero i=i0 () + +gcd52 : {i : ℕ } → 1 < suc (suc i) +gcd52 {zero} = a<sa +gcd52 {suc i} = <-trans (gcd52 {i}) a<sa + +gcd50 : (i i0 j j0 : ℕ) → 1 < i0 → i ≤ i0 → j ≤ j0 → gcd1 i i0 j j0 ≤ i0 +gcd50 zero i0 zero j0 0<i i<i0 j<j0 with <-cmp i0 j0 +... | tri< a ¬b ¬c = ≤-refl +... | tri≈ ¬a refl ¬c = ≤-refl +... | tri> ¬a ¬b c = ≤-trans refl-≤s c +gcd50 zero (suc i0) (suc zero) j0 0<i i<i0 j<j0 = gcd51 0<i where + gcd51 : 1 < suc i0 → gcd1 zero (suc i0) 1 j0 ≤ suc i0 + gcd51 1<i = ≤to< 1<i +gcd50 zero (suc i0) (suc (suc j)) j0 0<i i<i0 j<j0 = gcd50 i0 (suc i0) (suc j) (suc (suc j)) 0<i refl-≤s refl-≤s +gcd50 (suc zero) i0 zero j0 0<i i<i0 j<j0 = ≤to< 0<i +gcd50 (suc (suc i)) i0 zero zero 0<i i<i0 j<j0 = ≤-refl +gcd50 (suc (suc i)) i0 zero (suc j0) 0<i i<i0 j<j0 = ≤-trans (gcd50 (suc i) (suc (suc i)) j0 (suc j0) gcd52 refl-≤s refl-≤s) i<i0 +gcd50 (suc i) i0 (suc j) j0 0<i i<i0 j<j0 = subst (λ k → k ≤ i0 ) (sym (gcd22 i i0 j j0)) + (gcd50 i i0 j j0 0<i (≤-trans refl-≤s i<i0) (≤-trans refl-≤s j<j0)) + +gcd5 : ( n k : ℕ ) → 1 < n → gcd n k ≤ n +gcd5 n k 0<n = gcd50 n n k k 0<n ≤-refl ≤-refl + +gcd6 : ( n k : ℕ ) → 1 < n → gcd k n ≤ n +gcd6 n k 1<n = subst (λ m → m ≤ n) (gcdsym {n} {k}) (gcd5 n k 1<n) + +gcd4 : ( n k : ℕ ) → 1 < n → gcd n k ≡ k → k ≤ n +gcd4 n k 1<n eq = subst (λ m → m ≤ n ) eq (gcd5 n k 1<n) + +gcdmul+1 : ( m n : ℕ ) → gcd (m * n + 1) n ≡ 1 +gcdmul+1 zero n = gcd204 n +gcdmul+1 (suc m) n = begin + gcd (suc m * n + 1) n ≡⟨⟩ + gcd (n + m * n + 1) n ≡⟨ cong (λ k → gcd k n ) (begin + n + m * n + 1 ≡⟨ cong (λ k → k + 1) (+-comm n _) ⟩ + m * n + n + 1 ≡⟨ +-assoc (m * n) _ _ ⟩ + m * n + (n + 1) ≡⟨ cong (λ k → m * n + k) (+-comm n _) ⟩ + m * n + (1 + n) ≡⟨ sym ( +-assoc (m * n) _ _ ) ⟩ + m * n + 1 + n ∎ + ) ⟩ + gcd (m * n + 1 + n) n ≡⟨ gcd2 (m * n + 1) n ⟩ + gcd (m * n + 1) n ≡⟨ gcdmul+1 m n ⟩ + 1 ∎ where open ≡-Reasoning +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/automaton-in-agda/src/halt.agda Sun Jun 13 20:45:17 2021 +0900 @@ -0,0 +1,114 @@ +module halt where + +open import Level renaming ( zero to Zero ; suc to Suc ) +open import Data.Nat +open import Data.Maybe +open import Data.List hiding ([_]) +open import Data.Nat.Properties +open import Relation.Nullary +open import Data.Empty +open import Data.Unit +open import Relation.Binary.Core hiding (_⇔_) +open import Relation.Binary.Definitions +open import Relation.Binary.PropositionalEquality + +open import logic + +record HBijection {n m : Level} (R : Set n) (S : Set m) : Set (n Level.⊔ m) where + field + fun← : S → R + fun→ : R → S + fiso← : (x : R) → fun← ( fun→ x ) ≡ x +-- normal bijection required below, but we don't need this to show the inconsistency +-- fiso→ : (x : S ) → fun→ ( fun← x ) ≡ x + +injection : {n m : Level} (R : Set n) (S : Set m) (f : R → S ) → Set (n Level.⊔ m) +injection R S f = (x y : R) → f x ≡ f y → x ≡ y + +open HBijection + +diag : {S : Set } (b : HBijection ( S → Bool ) S) → S → Bool +diag b n = not (fun← b n n) + +diagonal : { S : Set } → ¬ HBijection ( S → Bool ) S +diagonal {S} b = diagn1 (fun→ b (diag b) ) refl where + diagn1 : (n : S ) → ¬ (fun→ b (diag b) ≡ n ) + diagn1 n dn = ¬t=f (diag b n ) ( begin + not (diag b n) + ≡⟨⟩ + not (not fun← b n n) + ≡⟨ cong (λ k → not (k n) ) (sym (fiso← b _)) ⟩ + not (fun← b (fun→ b (diag b)) n) + ≡⟨ cong (λ k → not (fun← b k n) ) dn ⟩ + not (fun← b n n) + ≡⟨⟩ + diag b n + ∎ ) where open ≡-Reasoning + +record TM : Set where + field + tm : List Bool → Maybe Bool + +open TM + +record UTM : Set where + field + utm : TM + encode : TM → List Bool + is-tm : (t : TM) → (x : List Bool) → tm utm (encode t ++ x ) ≡ tm t x + +open UTM + +open _∧_ + +open import Axiom.Extensionality.Propositional +postulate f-extensionality : { n : Level} → Axiom.Extensionality.Propositional.Extensionality n n + +record Halt : Set where + field + halt : (t : TM ) → (x : List Bool ) → Bool + is-halt : (t : TM ) → (x : List Bool ) → (halt t x ≡ true ) ⇔ ( (just true ≡ tm t x ) ∨ (just false ≡ tm t x ) ) + is-not-halt : (t : TM ) → (x : List Bool ) → (halt t x ≡ false ) ⇔ ( nothing ≡ tm t x ) + +open Halt + +TNL : (halt : Halt ) → (utm : UTM) → HBijection (List Bool → Bool) (List Bool) +TNL halt utm = record { + fun← = λ tm x → Halt.halt halt (UTM.utm utm) (tm ++ x) + ; fun→ = λ h → encode utm record { tm = h1 h } + ; fiso← = λ h → f-extensionality (λ y → TN1 h y ) + } where + open ≡-Reasoning + h1 : (h : List Bool → Bool) → (x : List Bool ) → Maybe Bool + h1 h x with h x + ... | true = just true + ... | false = nothing + tenc : (h : List Bool → Bool) → (y : List Bool) → List Bool + tenc h y = encode utm (record { tm = λ x → h1 h x }) ++ y + h-nothing : (h : List Bool → Bool) → (y : List Bool) → h y ≡ false → h1 h y ≡ nothing + h-nothing h y eq with h y + h-nothing h y refl | false = refl + h-just : (h : List Bool → Bool) → (y : List Bool) → h y ≡ true → h1 h y ≡ just true + h-just h y eq with h y + h-just h y refl | true = refl + TN1 : (h : List Bool → Bool) → (y : List Bool ) → Halt.halt halt (UTM.utm utm) (tenc h y) ≡ h y + TN1 h y with h y | inspect h y + ... | true | record { eq = eq1 } = begin + Halt.halt halt (UTM.utm utm) (tenc h y) ≡⟨ proj2 (is-halt halt (UTM.utm utm) (tenc h y) ) (case1 (sym tm-tenc)) ⟩ + true ∎ where + tm-tenc : tm (UTM.utm utm) (tenc h y) ≡ just true + tm-tenc = begin + tm (UTM.utm utm) (tenc h y) ≡⟨ is-tm utm _ y ⟩ + h1 h y ≡⟨ h-just h y eq1 ⟩ + just true ∎ + ... | false | record { eq = eq1 } = begin + Halt.halt halt (UTM.utm utm) (tenc h y) ≡⟨ proj2 (is-not-halt halt (UTM.utm utm) (tenc h y) ) (sym tm-tenc) ⟩ + false ∎ where + tm-tenc : tm (UTM.utm utm) (tenc h y) ≡ nothing + tm-tenc = begin + tm (UTM.utm utm) (tenc h y) ≡⟨ is-tm utm _ y ⟩ + h1 h y ≡⟨ h-nothing h y eq1 ⟩ + nothing ∎ + -- the rest of bijection means encoding is unique + -- fiso→ : (y : List Bool ) → encode utm record { tm = λ x → h1 (λ tm → Halt.halt halt (UTM.utm utm) tm ) x } ≡ y +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/automaton-in-agda/src/index.ind Sun Jun 13 20:45:17 2021 +0900 @@ -0,0 +1,31 @@ +--title: list +<a href=FSetUtil.agda> FSetUtil.agda </a><br> +<a href=automaton-ex.agda> automaton-ex.agda </a><br> +<a href=automaton.agda> automaton.agda </a><br> +<a href=cfg.agda> cfg.agda </a><br> +<a href=cfg1.agda> cfg1.agda </a><br> +<a href=chap0.agda> chap0.agda </a><br> +<a href=derive.agda> derive.agda </a><br> +<a href=even.agda> even.agda </a><br> +<a href=finiteSet.agda> finiteSet.agda </a><br> +<a href=flcagl.agda> flcagl.agda </a><br> +<a href=gcd.agda> gcd.agda </a><br> +<a href=halt.agda> halt.agda </a><br> +<a href=induction-ex.agda> induction-ex.agda </a><br> +<a href=lang-text.agda> lang-text.agda </a><br> +<a href=logic.agda> logic.agda </a><br> +<a href=nat.agda> nat.agda </a><br> +<a href=nfa.agda> nfa.agda </a><br> +<a href=nfa136.agda> nfa136.agda </a><br> +<a href=non-regular.agda> non-regular.agda </a><br> +<a href=omega-automaton.agda> omega-automaton.agda </a><br> +<a href=pushdown.agda> pushdown.agda </a><br> +<a href=puzzle.agda> puzzle.agda </a><br> +<a href=regex.agda> regex.agda </a><br> +<a href=regex1.agda> regex1.agda </a><br> +<a href=regular-concat.agda> regular-concat.agda </a><br> +<a href=regular-language.agda> regular-language.agda </a><br> +<a href=root2.agda> root2.agda </a><br> +<a href=sbconst2.agda> sbconst2.agda </a><br> +<a href=turing.agda> turing.agda </a><br> +<a href=utm.agda> utm.agda </a><br>
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/automaton-in-agda/src/induction-ex.agda Sun Jun 13 20:45:17 2021 +0900 @@ -0,0 +1,118 @@ +{-# OPTIONS --guardedness #-} +module induction-ex where + +open import Relation.Binary.PropositionalEquality +open import Size +open import Data.Bool + +data List (A : Set ) : Set where + [] : List A + _∷_ : A → List A → List A + +data Nat : Set where + zero : Nat + suc : Nat → Nat + +add : Nat → Nat → Nat +add zero x = x +add (suc x) y = suc ( add x y ) + +_++_ : {A : Set} → List A → List A → List A +[] ++ y = y +(x ∷ t) ++ y = x ∷ ( t ++ y ) + +test1 = (zero ∷ []) ++ (zero ∷ []) + +length : {A : Set } → List A → Nat +length [] = zero +length (_ ∷ t) = suc ( length t ) + +lemma1 : {A : Set} → (x y : List A ) → length ( x ++ y ) ≡ add (length x) (length y) +lemma1 [] y = refl +lemma1 (x ∷ t) y = cong ( λ k → suc k ) lemma2 where + lemma2 : length (t ++ y) ≡ add (length t) (length y) + lemma2 = lemma1 t y + +-- record List1 ( A : Set ) : Set where +-- inductive +-- field +-- nil : List1 A +-- cons : A → List1 A → List1 A +-- +-- record List2 ( A : Set ) : Set where +-- coinductive +-- field +-- nil : List2 A +-- cons : A → List2 A → List2 A + +data SList (i : Size) (A : Set) : Set where + []' : SList i A + _∷'_ : {j : Size< i} (x : A) (xs : SList j A) → SList i A + + +map : ∀{i A B} → (A → B) → SList i A → SList i B +map f []' = []' +map f ( x ∷' xs)= f x ∷' map f xs + +foldr : ∀{i} {A B : Set} → (A → B → B) → B → SList i A → B +foldr c n []' = n +foldr c n (x ∷' xs) = c x (foldr c n xs) + +any : ∀{i A} → (A → Bool) → SList i A → Bool +any p xs = foldr _∨_ false (map p xs) + +-- Sappend : {A : Set } {i j : Size } → SList i A → SList j A → SList {!!} A +-- Sappend []' y = y +-- Sappend (x ∷' x₁) y = _∷'_ {?} x (Sappend x₁ y) + +language : { Σ : Set } → Set +language {Σ} = List Σ → Bool + +record Lang (i : Size) (A : Set) : Set where + coinductive + field + ν : Bool + δ : ∀{j : Size< i} → A → Lang j A + +open Lang + +∅ : ∀ {i A} → Lang i A +ν ∅ = false +δ ∅ _ = ∅ + +∅' : {i : Size } { A : Set } → Lang i A +∅' {i} {A} = record { ν = false ; δ = lemma3 } where + lemma3 : {j : Size< i} → A → Lang j A + lemma3 {j} _ = {!!} + +∅l : {A : Set } → language {A} +∅l _ = false + +ε : ∀ {i A} → Lang i A +ν ε = true +δ ε _ = ∅ + +εl : {A : Set } → language {A} +εl [] = true +εl (_ ∷ _) = false + +_+_ : ∀ {i A} → Lang i A → Lang i A → Lang i A +ν (a + b) = ν a ∨ ν b +δ (a + b) x = δ a x + δ b x + +Union : {Σ : Set} → ( A B : language {Σ} ) → language {Σ} +Union {Σ} A B x = (A x ) ∨ (B x) + +_·_ : ∀ {i A} → Lang i A → Lang i A → Lang i A +ν (a · b) = ν a ∧ ν b +δ (a · b) x = if (ν a) then ((δ a x · b ) + (δ b x )) else ( δ a x · b ) + +split : {Σ : Set} → (List Σ → Bool) + → ( List Σ → Bool) → List Σ → Bool +split x y [] = x [] ∨ y [] +split x y (h ∷ t) = (x [] ∧ y (h ∷ t)) ∨ + split (λ t1 → x ( h ∷ t1 )) (λ t2 → y t2 ) t + +Concat : {Σ : Set} → ( A B : language {Σ} ) → language {Σ} +Concat {Σ} A B = split A B +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/automaton-in-agda/src/lang-text.agda Sun Jun 13 20:45:17 2021 +0900 @@ -0,0 +1,54 @@ +module lang-text where + +open import Data.List +open import Data.String +open import Data.Char +open import Data.Char.Unsafe +open import Relation.Binary.PropositionalEquality +open import Relation.Nullary +open import logic + +split : {Σ : Set} → (List Σ → Bool) + → ( List Σ → Bool) → List Σ → Bool +split x y [] = x [] /\ y [] +split x y (h ∷ t) = (x [] /\ y (h ∷ t)) \/ + split (λ t1 → x ( h ∷ t1 )) (λ t2 → y t2 ) t + +contains : String → String → Bool +contains x y = contains1 (toList x ) ( toList y ) where + contains1 : List Char → List Char → Bool + contains1 [] [] = false + contains1 [] ( cx ∷ ly ) = false + contains1 (cx ∷ lx) [] = true + contains1 (cx ∷ lx ) ( cy ∷ ly ) with cx ≟ cy + ... | yes refl = contains1 lx ly + ... | no n = false + +-- w does not contain the substring ab +ex15a : Set +ex15a = (w : String ) → ¬ (contains w "ab" ≡ true ) + +-- w does not contains substring baba +ex15b : Set +ex15b = (w : String ) → ¬ (contains w "baba" ≡ true ) + +-- w contains neither the substing ab nor ba +ex15c : Set + +-- w is any string not in a*b* +ex15c = (w : String ) → ( ¬ (contains w "ab" ≡ true ) /\ ( ¬ (contains w "ba" ≡ true ) + +ex15d : {!!} +ex15d = {!!} + +ex15e : {!!} +ex15e = {!!} + +ex15f : {!!} +ex15f = {!!} + +ex15g : {!!} +ex15g = {!!} + +ex15h : {!!} +ex15h = {!!}
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/automaton-in-agda/src/logic.agda Sun Jun 13 20:45:17 2021 +0900 @@ -0,0 +1,154 @@ +module logic where + +open import Level +open import Relation.Nullary +open import Relation.Binary hiding (_⇔_ ) +open import Data.Empty + + +data Bool : Set where + true : Bool + false : Bool + +record _∧_ {n m : Level} (A : Set n) ( B : Set m ) : Set (n ⊔ m) where + constructor ⟪_,_⟫ + field + proj1 : A + proj2 : B + +data _∨_ {n m : Level} (A : Set n) ( B : Set m ) : Set (n ⊔ m) where + case1 : A → A ∨ B + case2 : B → A ∨ B + +_⇔_ : {n m : Level } → ( A : Set n ) ( B : Set m ) → Set (n ⊔ m) +_⇔_ A B = ( A → B ) ∧ ( B → A ) + +contra-position : {n m : Level } {A : Set n} {B : Set m} → (A → B) → ¬ B → ¬ A +contra-position {n} {m} {A} {B} f ¬b a = ¬b ( f a ) + +double-neg : {n : Level } {A : Set n} → A → ¬ ¬ A +double-neg A notnot = notnot A + +double-neg2 : {n : Level } {A : Set n} → ¬ ¬ ¬ A → ¬ A +double-neg2 notnot A = notnot ( double-neg A ) + +de-morgan : {n : Level } {A B : Set n} → A ∧ B → ¬ ( (¬ A ) ∨ (¬ B ) ) +de-morgan {n} {A} {B} and (case1 ¬A) = ⊥-elim ( ¬A ( _∧_.proj1 and )) +de-morgan {n} {A} {B} and (case2 ¬B) = ⊥-elim ( ¬B ( _∧_.proj2 and )) + +dont-or : {n m : Level} {A : Set n} { B : Set m } → A ∨ B → ¬ A → B +dont-or {A} {B} (case1 a) ¬A = ⊥-elim ( ¬A a ) +dont-or {A} {B} (case2 b) ¬A = b + +dont-orb : {n m : Level} {A : Set n} { B : Set m } → A ∨ B → ¬ B → A +dont-orb {A} {B} (case2 b) ¬B = ⊥-elim ( ¬B b ) +dont-orb {A} {B} (case1 a) ¬B = a + +infixr 130 _∧_ +infixr 140 _∨_ +infixr 150 _⇔_ + +_/\_ : Bool → Bool → Bool +true /\ true = true +_ /\ _ = false + +_\/_ : Bool → Bool → Bool +false \/ false = false +_ \/ _ = true + +not_ : Bool → Bool +not true = false +not false = true + +_<=>_ : Bool → Bool → Bool +true <=> true = true +false <=> false = true +_ <=> _ = false + +open import Relation.Binary.PropositionalEquality + +¬t=f : (t : Bool ) → ¬ ( not t ≡ t) +¬t=f true () +¬t=f false () + +infixr 130 _\/_ +infixr 140 _/\_ + +≡-Bool-func : {A B : Bool } → ( A ≡ true → B ≡ true ) → ( B ≡ true → A ≡ true ) → A ≡ B +≡-Bool-func {true} {true} a→b b→a = refl +≡-Bool-func {false} {true} a→b b→a with b→a refl +... | () +≡-Bool-func {true} {false} a→b b→a with a→b refl +... | () +≡-Bool-func {false} {false} a→b b→a = refl + +bool-≡-? : (a b : Bool) → Dec ( a ≡ b ) +bool-≡-? true true = yes refl +bool-≡-? true false = no (λ ()) +bool-≡-? false true = no (λ ()) +bool-≡-? false false = yes refl + +¬-bool-t : {a : Bool} → ¬ ( a ≡ true ) → a ≡ false +¬-bool-t {true} ne = ⊥-elim ( ne refl ) +¬-bool-t {false} ne = refl + +¬-bool-f : {a : Bool} → ¬ ( a ≡ false ) → a ≡ true +¬-bool-f {true} ne = refl +¬-bool-f {false} ne = ⊥-elim ( ne refl ) + +¬-bool : {a : Bool} → a ≡ false → a ≡ true → ⊥ +¬-bool refl () + +lemma-∧-0 : {a b : Bool} → a /\ b ≡ true → a ≡ false → ⊥ +lemma-∧-0 {true} {true} refl () +lemma-∧-0 {true} {false} () +lemma-∧-0 {false} {true} () +lemma-∧-0 {false} {false} () + +lemma-∧-1 : {a b : Bool} → a /\ b ≡ true → b ≡ false → ⊥ +lemma-∧-1 {true} {true} refl () +lemma-∧-1 {true} {false} () +lemma-∧-1 {false} {true} () +lemma-∧-1 {false} {false} () + +bool-and-tt : {a b : Bool} → a ≡ true → b ≡ true → ( a /\ b ) ≡ true +bool-and-tt refl refl = refl + +bool-∧→tt-0 : {a b : Bool} → ( a /\ b ) ≡ true → a ≡ true +bool-∧→tt-0 {true} {true} refl = refl +bool-∧→tt-0 {false} {_} () + +bool-∧→tt-1 : {a b : Bool} → ( a /\ b ) ≡ true → b ≡ true +bool-∧→tt-1 {true} {true} refl = refl +bool-∧→tt-1 {true} {false} () +bool-∧→tt-1 {false} {false} () + +bool-or-1 : {a b : Bool} → a ≡ false → ( a \/ b ) ≡ b +bool-or-1 {false} {true} refl = refl +bool-or-1 {false} {false} refl = refl +bool-or-2 : {a b : Bool} → b ≡ false → (a \/ b ) ≡ a +bool-or-2 {true} {false} refl = refl +bool-or-2 {false} {false} refl = refl + +bool-or-3 : {a : Bool} → ( a \/ true ) ≡ true +bool-or-3 {true} = refl +bool-or-3 {false} = refl + +bool-or-31 : {a b : Bool} → b ≡ true → ( a \/ b ) ≡ true +bool-or-31 {true} {true} refl = refl +bool-or-31 {false} {true} refl = refl + +bool-or-4 : {a : Bool} → ( true \/ a ) ≡ true +bool-or-4 {true} = refl +bool-or-4 {false} = refl + +bool-or-41 : {a b : Bool} → a ≡ true → ( a \/ b ) ≡ true +bool-or-41 {true} {b} refl = refl + +bool-and-1 : {a b : Bool} → a ≡ false → (a /\ b ) ≡ false +bool-and-1 {false} {b} refl = refl +bool-and-2 : {a b : Bool} → b ≡ false → (a /\ b ) ≡ false +bool-and-2 {true} {false} refl = refl +bool-and-2 {false} {false} refl = refl + +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/automaton-in-agda/src/nfa.agda Sun Jun 13 20:45:17 2021 +0900 @@ -0,0 +1,152 @@ +{-# OPTIONS --allow-unsolved-metas #-} +module nfa where + +-- open import Level renaming ( suc to succ ; zero to Zero ) +open import Data.Nat +open import Data.List +open import Data.Fin hiding ( _<_ ) +open import Data.Maybe +open import Relation.Nullary +open import Data.Empty +-- open import Data.Bool using ( Bool ; true ; false ; _∧_ ; _∨_ ) +open import Relation.Binary.PropositionalEquality hiding ( [_] ) +open import Relation.Nullary using (¬_; Dec; yes; no) +open import logic + +data States1 : Set where + sr : States1 + ss : States1 + st : States1 + +data In2 : Set where + i0 : In2 + i1 : In2 + + +record NAutomaton ( Q : Set ) ( Σ : Set ) + : Set where + field + Nδ : Q → Σ → Q → Bool + Nend : Q → Bool + +open NAutomaton + +LStates1 : List States1 +LStates1 = sr ∷ ss ∷ st ∷ [] + +-- one of qs q is true +existsS1 : ( States1 → Bool ) → Bool +existsS1 qs = qs sr \/ qs ss \/ qs st + +-- extract list of q which qs q is true +to-listS1 : ( States1 → Bool ) → List States1 +to-listS1 qs = ss1 LStates1 where + ss1 : List States1 → List States1 + ss1 [] = [] + ss1 (x ∷ t) with qs x + ... | true = x ∷ ss1 t + ... | false = ss1 t + +Nmoves : { Q : Set } { Σ : Set } + → NAutomaton Q Σ + → (exists : ( Q → Bool ) → Bool) + → ( Qs : Q → Bool ) → (s : Σ ) → Q → Bool +Nmoves {Q} { Σ} M exists Qs s q = + exists ( λ qn → (Qs qn /\ ( Nδ M qn s q ) )) + +Naccept : { Q : Set } { Σ : Set } + → NAutomaton Q Σ + → (exists : ( Q → Bool ) → Bool) + → (Nstart : Q → Bool) → List Σ → Bool +Naccept M exists sb [] = exists ( λ q → sb q /\ Nend M q ) +Naccept M exists sb (i ∷ t ) = Naccept M exists (λ q → exists ( λ qn → (sb qn /\ ( Nδ M qn i q ) ))) t + +Ntrace : { Q : Set } { Σ : Set } + → NAutomaton Q Σ + → (exists : ( Q → Bool ) → Bool) + → (to-list : ( Q → Bool ) → List Q ) + → (Nstart : Q → Bool) → List Σ → List (List Q) +Ntrace M exists to-list sb [] = to-list ( λ q → sb q /\ Nend M q ) ∷ [] +Ntrace M exists to-list sb (i ∷ t ) = + to-list (λ q → sb q ) ∷ + Ntrace M exists to-list (λ q → exists ( λ qn → (sb qn /\ ( Nδ M qn i q ) ))) t + + +transition3 : States1 → In2 → States1 → Bool +transition3 sr i0 sr = true +transition3 sr i1 ss = true +transition3 sr i1 sr = true +transition3 ss i0 sr = true +transition3 ss i1 st = true +transition3 st i0 sr = true +transition3 st i1 st = true +transition3 _ _ _ = false + +fin1 : States1 → Bool +fin1 st = true +fin1 ss = false +fin1 sr = false + +test5 = existsS1 (λ q → fin1 q ) +test6 = to-listS1 (λ q → fin1 q ) + +start1 : States1 → Bool +start1 sr = true +start1 _ = false + +am2 : NAutomaton States1 In2 +am2 = record { Nδ = transition3 ; Nend = fin1} + +example2-1 = Naccept am2 existsS1 start1 ( i0 ∷ i1 ∷ i0 ∷ [] ) +example2-2 = Naccept am2 existsS1 start1 ( i1 ∷ i1 ∷ i1 ∷ [] ) + +t-1 : List ( List States1 ) +t-1 = Ntrace am2 existsS1 to-listS1 start1 ( i1 ∷ i1 ∷ i1 ∷ [] ) +t-2 = Ntrace am2 existsS1 to-listS1 start1 ( i0 ∷ i1 ∷ i0 ∷ [] ) + +transition4 : States1 → In2 → States1 → Bool +transition4 sr i0 sr = true +transition4 sr i1 ss = true +transition4 sr i1 sr = true +transition4 ss i0 ss = true +transition4 ss i1 st = true +transition4 st i0 st = true +transition4 st i1 st = true +transition4 _ _ _ = false + +fin4 : States1 → Bool +fin4 st = true +fin4 _ = false + +start4 : States1 → Bool +start4 ss = true +start4 _ = false + +am4 : NAutomaton States1 In2 +am4 = record { Nδ = transition4 ; Nend = fin4} + +example4-1 = Naccept am4 existsS1 start4 ( i0 ∷ i1 ∷ i1 ∷ i0 ∷ [] ) +example4-2 = Naccept am4 existsS1 start4 ( i0 ∷ i1 ∷ i1 ∷ i1 ∷ [] ) + +fin0 : States1 → Bool +fin0 st = false +fin0 ss = false +fin0 sr = false + +test0 : Bool +test0 = existsS1 fin0 + +test1 : Bool +test1 = existsS1 fin1 + +test2 = Nmoves am2 existsS1 start1 + +open import automaton + +am2def : Automaton (States1 → Bool ) In2 +am2def = record { δ = λ qs s q → existsS1 (λ qn → qs q /\ Nδ am2 q s qn ) + ; aend = λ qs → existsS1 (λ q → qs q /\ Nend am2 q) } + +dexample4-1 = accept am2def start1 ( i0 ∷ i1 ∷ i1 ∷ i0 ∷ [] ) +texample4-1 = trace am2def start1 ( i0 ∷ i1 ∷ i1 ∷ i0 ∷ [] ) +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/automaton-in-agda/src/nfa136.agda Sun Jun 13 20:45:17 2021 +0900 @@ -0,0 +1,113 @@ +module nfa136 where + +open import logic +open import nfa +open import automaton +open import Data.List +open import finiteSet +open import Data.Fin +open import Relation.Binary.PropositionalEquality hiding ( [_] ) + +data StatesQ : Set where + q1 : StatesQ + q2 : StatesQ + q3 : StatesQ + +data A2 : Set where + a0 : A2 + b0 : A2 + +finStateQ : FiniteSet StatesQ +finStateQ = record { + Q←F = Q←F + ; F←Q = F←Q + ; finiso→ = finiso→ + ; finiso← = finiso← + } where + Q←F : Fin 3 → StatesQ + Q←F zero = q1 + Q←F (suc zero) = q2 + Q←F (suc (suc zero)) = q3 + F←Q : StatesQ → Fin 3 + F←Q q1 = zero + F←Q q2 = suc zero + F←Q q3 = suc (suc zero) + finiso→ : (q : StatesQ) → Q←F (F←Q q) ≡ q + finiso→ q1 = refl + finiso→ q2 = refl + finiso→ q3 = refl + finiso← : (f : Fin 3) → F←Q (Q←F f) ≡ f + finiso← zero = refl + finiso← (suc zero) = refl + finiso← (suc (suc zero)) = refl + finiso← (suc (suc (suc ()))) + +transition136 : StatesQ → A2 → StatesQ → Bool +transition136 q1 b0 q2 = true +transition136 q1 a0 q1 = true -- q1 → ep → q3 +transition136 q2 a0 q2 = true +transition136 q2 a0 q3 = true +transition136 q2 b0 q3 = true +transition136 q3 a0 q1 = true +transition136 _ _ _ = false + +end136 : StatesQ → Bool +end136 q1 = true +end136 _ = false + +start136 : StatesQ → Bool +start136 q1 = true +start136 _ = false + +exists136 : (StatesQ → Bool) → Bool +exists136 f = f q1 \/ f q2 \/ f q3 + +to-list-136 : (StatesQ → Bool) → List StatesQ +to-list-136 f = tl1 where + tl3 : List StatesQ + tl3 with f q3 + ... | true = q3 ∷ [] + ... | false = [] + tl2 : List StatesQ + tl2 with f q2 + ... | true = q2 ∷ tl3 + ... | false = tl3 + tl1 : List StatesQ + tl1 with f q1 + ... | true = q1 ∷ tl2 + ... | false = tl2 + +nfa136 : NAutomaton StatesQ A2 +nfa136 = record { Nδ = transition136; Nend = end136 } + +example136-1 = Naccept nfa136 exists136 start136( a0 ∷ b0 ∷ a0 ∷ a0 ∷ [] ) + +t146-1 = Ntrace nfa136 exists136 to-list-136 start136( a0 ∷ b0 ∷ a0 ∷ a0 ∷ [] ) + +example136-0 = Naccept nfa136 exists136 start136( a0 ∷ [] ) + +example136-2 = Naccept nfa136 exists136 start136( b0 ∷ a0 ∷ b0 ∷ a0 ∷ b0 ∷ [] ) +t146-2 = Ntrace nfa136 exists136 to-list-136 start136( b0 ∷ a0 ∷ b0 ∷ a0 ∷ b0 ∷ [] ) + +open FiniteSet + +nx : (StatesQ → Bool) → (List A2 ) → StatesQ → Bool +nx now [] = now +nx now ( i ∷ ni ) = (Nmoves nfa136 exists136 (nx now ni) i ) + +example136-3 = to-list-136 start136 +example136-4 = to-list-136 (nx start136 ( a0 ∷ b0 ∷ a0 ∷ [] )) + +open import sbconst2 + +fm136 : Automaton ( StatesQ → Bool ) A2 +fm136 = subset-construction exists136 nfa136 + +open NAutomaton + +lemma136 : ( x : List A2 ) → Naccept nfa136 exists136 start136 x ≡ accept fm136 start136 x +lemma136 x = lemma136-1 x start136 where + lemma136-1 : ( x : List A2 ) → ( states : StatesQ → Bool ) + → Naccept nfa136 exists136 states x ≡ accept fm136 states x + lemma136-1 [] _ = refl + lemma136-1 (h ∷ t) states = lemma136-1 t (δconv exists136 (Nδ nfa136) states h)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/automaton-in-agda/src/non-regular.agda Sun Jun 13 20:45:17 2021 +0900 @@ -0,0 +1,20 @@ +module non-regular where + +open import Data.Nat +open import Data.List +open import Relation.Binary.PropositionalEquality hiding ( [_] ) +open import logic +open import automaton +open import finiteSet +open import Relation.Nullary + +inputnn : ( n : ℕ ) → { Σ : Set } → ( x y : Σ ) → List Σ → List Σ +inputnn zero {_} _ _ s = s +inputnn (suc n) x y s = x ∷ ( inputnn n x y ( y ∷ s ) ) + +lemmaNN : { Q : Set } { Σ : Set } → ( x y : Σ ) → ¬ (x ≡ y) + → FiniteSet Q + → (M : Automaton Q Σ) (q : Q) + → ¬ ( (n : ℕ) → accept M q ( inputnn n x y [] ) ≡ true ) +lemmaNN = {!!} +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/automaton-in-agda/src/omega-automaton.agda Sun Jun 13 20:45:17 2021 +0900 @@ -0,0 +1,155 @@ +module omega-automaton where + +open import Level renaming ( suc to succ ; zero to Zero ) +open import Data.Nat +open import Data.List +open import Data.Maybe +-- open import Data.Bool using ( Bool ; true ; false ; _∧_ ) renaming ( not to negate ) +open import Relation.Binary.PropositionalEquality hiding ( [_] ) +open import Relation.Nullary -- using (not_; Dec; yes; no) +open import Data.Empty + +open import logic +open import automaton + +open Automaton + +ω-run : { Q Σ : Set } → (Ω : Automaton Q Σ ) → (astart : Q ) → ℕ → ( ℕ → Σ ) → Q +ω-run Ω x zero s = x +ω-run Ω x (suc n) s = δ Ω (ω-run Ω x n s) ( s n ) + +-- +-- accept as Buchi automaton +-- +record Buchi { Q Σ : Set } (Ω : Automaton Q Σ ) ( S : ℕ → Σ ) : Set where + field + from : ℕ + stay : (x : Q) → (n : ℕ ) → n > from → aend Ω ( ω-run Ω x n S ) ≡ true + +open Buchi + +-- after sometimes, always p +-- +-- not p +-- ------------> +-- <> [] p * <> [] p +-- <----------- +-- p + + +-- +-- accept as Muller automaton +-- +record Muller { Q Σ : Set } (Ω : Automaton Q Σ ) ( S : ℕ → Σ ) : Set where + field + next : (n : ℕ ) → ℕ + infinite : (x : Q) → (n : ℕ ) → aend Ω ( ω-run Ω x (n + (next n)) S ) ≡ true + +-- always sometimes p +-- +-- not p +-- ------------> +-- [] <> p * [] <> p +-- <----------- +-- p + +data States3 : Set where + ts* : States3 + ts : States3 + +transition3 : States3 → Bool → States3 +transition3 ts* true = ts* +transition3 ts* false = ts +transition3 ts true = ts* +transition3 ts false = ts + +mark1 : States3 → Bool +mark1 ts* = true +mark1 ts = false + +ωa1 : Automaton States3 Bool +ωa1 = record { + δ = transition3 + ; aend = mark1 + } + +true-seq : ℕ → Bool +true-seq _ = true + +false-seq : ℕ → Bool +false-seq _ = false + +flip-seq : ℕ → Bool +flip-seq zero = false +flip-seq (suc n) = not ( flip-seq n ) + +lemma0 : Muller ωa1 flip-seq +lemma0 = record { + next = λ n → suc (suc n) + ; infinite = lemma01 + } where + lemma01 : (x : States3) (n : ℕ) → + aend ωa1 (ω-run ωa1 x (n + suc (suc n)) flip-seq) ≡ true + lemma01 = {!!} + +lemma1 : Buchi ωa1 true-seq +lemma1 = record { + from = zero + ; stay = {!!} + } where + lem1 : ( n : ℕ ) → n > zero → aend ωa1 (ω-run ωa1 {!!} n true-seq ) ≡ true + lem1 zero () + lem1 (suc n) (s≤s z≤n) with ω-run ωa1 {!!} n true-seq + lem1 (suc n) (s≤s z≤n) | ts* = {!!} + lem1 (suc n) (s≤s z≤n) | ts = {!!} + +ωa2 : Automaton States3 Bool +ωa2 = record { + δ = transition3 + ; aend = λ x → not ( mark1 x ) + } + +flip-dec : (n : ℕ ) → Dec ( flip-seq n ≡ true ) +flip-dec n with flip-seq n +flip-dec n | false = no λ () +flip-dec n | true = yes refl + +flip-dec1 : (n : ℕ ) → flip-seq (suc n) ≡ ( not ( flip-seq n ) ) +flip-dec1 n = let open ≡-Reasoning in + flip-seq (suc n ) + ≡⟨⟩ + ( not ( flip-seq n ) ) + ∎ + +flip-dec2 : (n : ℕ ) → not flip-seq (suc n) ≡ flip-seq n +flip-dec2 n = {!!} + + +record flipProperty : Set where + field + flipP : (n : ℕ) → ω-run ωa2 {!!} {!!} ≡ ω-run ωa2 {!!} {!!} + +lemma2 : Muller ωa2 flip-seq +lemma2 = record { + next = next + ; infinite = {!!} + } where + next : ℕ → ℕ + next = {!!} + infinite' : (n m : ℕ) → n ≥″ m → aend ωa2 {!!} ≡ true → aend ωa2 {!!} ≡ true + infinite' = {!!} + infinite : (n : ℕ) → aend ωa2 {!!} ≡ true + infinite = {!!} + +lemma3 : Buchi ωa1 false-seq → ⊥ +lemma3 = {!!} + +lemma4 : Muller ωa1 flip-seq → ⊥ +lemma4 = {!!} + + + + + + +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/automaton-in-agda/src/prime.agda Sun Jun 13 20:45:17 2021 +0900 @@ -0,0 +1,51 @@ +module prime where + +open import Data.Nat +open import Data.Nat.Properties +open import Data.Empty +open import Data.Unit using (⊤ ; tt) +open import Relation.Nullary +open import Relation.Binary.PropositionalEquality +open import Relation.Binary.Definitions + +open import gcd +open import nat + +record Prime (i : ℕ ) : Set where + field + isPrime : ( j : ℕ ) → j < i → gcd i j ≡ 1 + +open ≡-Reasoning + +record NonPrime ( n : ℕ ) : Set where + field + factor : ℕ + prime : Prime factor + dividable : Dividable factor n + +isPrime : ( n : ℕ ) → Dec ( Prime n ) +isPrime = {!!} + +nonPrime : ( n : ℕ ) → ¬ Prime n → NonPrime n +nonPrime n np = np1 n (λ j n≤j j<n → ⊥-elim (nat-≤> n≤j j<n ) ) where + np1 : ( m : ℕ ) → ( (j : ℕ ) → m ≤ j → j < n → gcd n j ≡ 1 ) → NonPrime n + np1 zero mg = ⊥-elim ( np record { isPrime = λ j lt → mg j z≤n lt } ) -- zero < j , j < n + np1 (suc m) mg with <-cmp ( gcd n (suc m) ) 1 + ... | tri< a ¬b ¬c = {!!} + ... | tri≈ ¬a b ¬c = np1 m {!!} + ... | tri> ¬a ¬b c = record { factor = gcd n (suc m) ; prime = {!!} ; dividable = record { factor = {!!} ; is-factor = {!!} } } + +prime-is-infinite : (max-prime : ℕ ) → ¬ ( (j : ℕ) → max-prime < j → ¬ Prime j ) +prime-is-infinite zero pmax = pmax 1 {!!} record { isPrime = λ n lt → {!!} } +prime-is-infinite (suc m) pmax = pmax (suc (factorial (suc m))) f>m record { isPrime = λ n lt → fact n lt } where + factorial : (n : ℕ) → ℕ + factorial zero = 1 + factorial (suc n) = (suc n) * (factorial n) + f>m : suc m < suc (factorial (suc m)) + f>m = {!!} + factm : (n m : ℕ ) → n < (suc m) → Dividable n (factorial m ) + factm = {!!} + fact : (n : ℕ ) → n < (suc (factorial (suc m))) → gcd (suc (factorial (suc m))) n ≡ 1 + fact n lt = fact12 (nonPrime (factorial (suc m )) ( pmax (factorial (suc m )) {!!} )) where + fact12 : NonPrime (factorial (suc m)) → gcd (suc (factorial (suc m))) n ≡ 1 + fact12 np = {!!}
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/automaton-in-agda/src/pushdown.agda Sun Jun 13 20:45:17 2021 +0900 @@ -0,0 +1,118 @@ +module pushdown where + +open import Level renaming ( suc to succ ; zero to Zero ) +open import Data.Nat +open import Data.List +open import Data.Maybe +open import Data.Bool using ( Bool ; true ; false ) +open import Relation.Binary.PropositionalEquality hiding ( [_] ) +open import Relation.Nullary using (¬_; Dec; yes; no) +open import Level renaming ( suc to succ ; zero to Zero ) +open import Data.Product + + +data PushDown ( Γ : Set ) : Set where + pop : PushDown Γ + push : Γ → PushDown Γ + + +record PushDownAutomaton ( Q : Set ) ( Σ : Set ) ( Γ : Set ) + : Set where + field + pδ : Q → Σ → Γ → Q × ( PushDown Γ ) + pok : Q → Bool + pempty : Γ + pmoves : Q → List Γ → Σ → ( Q × List Γ ) + pmoves q [] i with pδ q i pempty + pmoves q [] i | qn , pop = ( qn , [] ) + pmoves q [] i | qn , push x = ( qn , ( x ∷ [] ) ) + pmoves q ( H ∷ T ) i with pδ q i H + pmoves q (H ∷ T) i | qn , pop = ( qn , T ) + pmoves q (H ∷ T) i | qn , push x = ( qn , ( x ∷ H ∷ T) ) + + paccept : (q : Q ) ( In : List Σ ) ( sp : List Γ ) → Bool + paccept q [] [] = pok q + paccept q ( H ∷ T) [] with pδ q H pempty + paccept q (H ∷ T) [] | qn , pop = paccept qn T [] + paccept q (H ∷ T) [] | qn , push x = paccept qn T (x ∷ [] ) + paccept q [] (_ ∷ _ ) = false + paccept q ( H ∷ T ) ( SH ∷ ST ) with pδ q H SH + ... | (nq , pop ) = paccept nq T ST + ... | (nq , push ns ) = paccept nq T ( ns ∷ SH ∷ ST ) + + +-- 0011 +-- 00000111111 +inputnn : ( n : ℕ ) → { Σ : Set } → ( x y : Σ ) → List Σ → List Σ +inputnn zero {_} _ _ s = s +inputnn (suc n) x y s = x ∷ ( inputnn n x y ( y ∷ s ) ) + + +data States0 : Set where + sr : States0 + +data In2 : Set where + i0 : In2 + i1 : In2 + +test0 = inputnn 5 i0 i1 [] + +pnn : PushDownAutomaton States0 In2 States0 +pnn = record { + pδ = pδ + ; pempty = sr + ; pok = λ q → true + } where + pδ : States0 → In2 → States0 → States0 × PushDown States0 + pδ sr i0 _ = (sr , push sr) + pδ sr i1 _ = (sr , pop ) + +data States1 : Set where + ss : States1 + st : States1 + +pn1 : PushDownAutomaton States1 In2 States1 +pn1 = record { + pδ = pδ + ; pempty = ss + ; pok = pok1 + } where + pok1 : States1 → Bool + pok1 ss = false + pok1 st = true + pδ : States1 → In2 → States1 → States1 × PushDown States1 + pδ ss i0 _ = (ss , push ss) + pδ ss i1 _ = (st , pop) + pδ st i0 _ = (st , push ss) + pδ st i1 _ = (st , pop ) + +test1 = PushDownAutomaton.paccept pnn sr ( i0 ∷ i0 ∷ i1 ∷ i1 ∷ [] ) [] +test2 = PushDownAutomaton.paccept pnn sr ( i0 ∷ i0 ∷ i1 ∷ i0 ∷ [] ) [] +test3 = PushDownAutomaton.pmoves pnn sr [] i0 +test4 = PushDownAutomaton.paccept pnn sr ( i0 ∷ i0 ∷ i1 ∷ i1 ∷ i0 ∷ i1 ∷ [] ) [] + +test5 = PushDownAutomaton.paccept pn1 ss ( i0 ∷ i0 ∷ i1 ∷ i1 ∷ [] ) [] +test6 = PushDownAutomaton.paccept pn1 ss ( i0 ∷ i0 ∷ i1 ∷ i1 ∷ i0 ∷ i1 ∷ [] ) [] + +open import Data.Empty + +test70 : (n : ℕ ) → (x : List In2) → PushDownAutomaton.paccept pnn sr x [] ≡ true → inputnn n i0 i1 [] ≡ x +test70 zero [] refl = refl +test70 zero (x ∷ y) pa = ⊥-elim (test701 pa) where + test701 : PushDownAutomaton.paccept pnn sr (x ∷ y) [] ≡ true → ⊥ + test701 pa with PushDownAutomaton.pδ pnn sr x sr + ... | sr , pop = {!!} + ... | sr , push x = {!!} +test70 (suc n) x pa = {!!} + +test71 : (n : ℕ ) → (x : List In2) → inputnn n i0 i1 [] ≡ x → PushDownAutomaton.paccept pnn sr x [] ≡ true +test71 = {!!} + +test7 : (n : ℕ ) → PushDownAutomaton.paccept pnn sr (inputnn n i0 i1 []) [] ≡ true +test7 zero = refl +test7 (suc n) with test7 n +... | t = test7lem [] t where + test7lem : (x : List States0) → PushDownAutomaton.paccept pnn sr (inputnn n i0 i1 []) x ≡ true + → PushDownAutomaton.paccept pnn sr (inputnn n i0 i1 (i1 ∷ [])) (sr ∷ x) ≡ true + test7lem x with PushDownAutomaton.paccept pnn sr (inputnn (suc n) i0 i1 []) (sr ∷ x) + ... | t2 = {!!}
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/automaton-in-agda/src/puzzle.agda Sun Jun 13 20:45:17 2021 +0900 @@ -0,0 +1,194 @@ +module puzzle where + +---- 仮定 +-- 猫か犬を飼っている人は山羊を飼ってない +-- 猫を飼ってない人は、犬かウサギを飼っている +-- 猫も山羊も飼っていない人は、ウサギを飼っている +-- +---- 問題 +-- 山羊を飼っている人は、犬を飼っていない +-- 山羊を飼っている人は、ウサギを飼っている +-- ウサギを飼っていない人は、猫を飼っている + +module pet-research where + open import logic + open import Relation.Nullary + open import Data.Empty + + postulate + lem : (a : Set) → a ∨ ( ¬ a ) + + record PetResearch ( Cat Dog Goat Rabbit : Set ) : Set where + field + fact1 : ( Cat ∨ Dog ) → ¬ Goat + fact2 : ¬ Cat → ( Dog ∨ Rabbit ) + fact3 : ¬ ( Cat ∨ Goat ) → Rabbit + + module tmp ( Cat Dog Goat Rabbit : Set ) (p : PetResearch Cat Dog Goat Rabbit ) where + + open PetResearch + + problem0 : Cat ∨ Dog ∨ Goat ∨ Rabbit + problem0 with lem Cat | lem Goat + ... | case1 c | g = case1 c + ... | c | case1 g = case2 ( case2 ( case1 g ) ) + ... | case2 ¬c | case2 ¬g = case2 ( case2 ( case2 ( fact3 p lemma1 ))) where + lemma1 : ¬ ( Cat ∨ Goat ) + lemma1 (case1 c) = ¬c c + lemma1 (case2 g) = ¬g g + + problem1 : Goat → ¬ Dog + problem1 g d = fact1 p (case2 d) g + + problem2 : Goat → Rabbit + problem2 g with lem Cat | lem Dog + problem2 g | case1 c | d = ⊥-elim ( fact1 p (case1 c ) g ) + problem2 g | case2 ¬c | case1 d = ⊥-elim ( fact1 p (case2 d ) g ) + problem2 g | case2 ¬c | case2 ¬d with lem Rabbit + ... | case1 r = r + ... | case2 ¬r = fact3 p lemma2 where + lemma2 : ¬ ( Cat ∨ Goat ) + lemma2 (case1 c) = ¬c c + lemma2 (case2 g) with fact2 p ¬c + lemma2 (case2 g) | case1 d = ¬d d + lemma2 (case2 g) | case2 r = ¬r r + + problem3 : (¬ Rabbit ) → Cat + problem3 ¬r with lem Cat | lem Goat + problem3 ¬r | case1 c | g = c + problem3 ¬r | case2 ¬c | g = ⊥-elim ( ¬r ( fact3 p lemma3 )) where + lemma3 : ¬ ( Cat ∨ Goat ) + lemma3 (case1 c) = ¬c c + lemma3 (case2 g) with fact2 p ¬c + lemma3 (case2 g) | case1 d = fact1 p (case2 d ) g + lemma3 (case2 g) | case2 r = ¬r r + +module pet-research1 ( Cat Dog Goat Rabbit : Set ) where + + open import Data.Bool + open import Relation.Binary + open import Relation.Binary.PropositionalEquality + + _=>_ : Bool → Bool → Bool + _ => true = true + false => _ = true + true => false = false + + ¬_ : Bool → Bool + ¬ p = not p + + problem0 : ( Cat Dog Goat Rabbit : Bool ) → + ((( Cat ∨ Dog ) => (¬ Goat) ) ∧ ( (¬ Cat ) => ( Dog ∨ Rabbit ) ) ∧ ( ( ¬ ( Cat ∨ Goat ) ) => Rabbit ) ) + => (Cat ∨ Dog ∨ Goat ∨ Rabbit) ≡ true + problem0 true d g r = refl + problem0 false true g r = refl + problem0 false false true r = refl + problem0 false false false true = refl + problem0 false false false false = refl + + problem1 : ( Cat Dog Goat Rabbit : Bool ) → + ((( Cat ∨ Dog ) => (¬ Goat) ) ∧ ( (¬ Cat ) => ( Dog ∨ Rabbit ) ) ∧ ( ( ¬ ( Cat ∨ Goat ) ) => Rabbit ) ) + => ( Goat => ( ¬ Dog )) ≡ true + problem1 c false false r = refl + problem1 c true false r = refl + problem1 c false true r = refl + problem1 false true true r = refl + problem1 true true true r = refl + + problem2 : ( Cat Dog Goat Rabbit : Bool ) → + ((( Cat ∨ Dog ) => (¬ Goat) ) ∧ ( (¬ Cat ) => ( Dog ∨ Rabbit ) ) ∧ ( ( ¬ ( Cat ∨ Goat ) ) => Rabbit ) ) + => ( Goat => Rabbit ) ≡ true + problem2 c d false false = refl + problem2 c d false true = refl + problem2 c d true true = refl + problem2 true d true false = refl + problem2 false false true false = refl + problem2 false true true false = refl + + problem3 : ( Cat Dog Goat Rabbit : Bool ) → + ((( Cat ∨ Dog ) => (¬ Goat) ) ∧ ( (¬ Cat ) => ( Dog ∨ Rabbit ) ) ∧ ( ( ¬ ( Cat ∨ Goat ) ) => Rabbit ) ) + => ( (¬ Rabbit ) => Cat ) ≡ true + problem3 false d g true = refl + problem3 true d g true = refl + problem3 true d g false = refl + problem3 false false false false = refl + problem3 false false true false = refl + problem3 false true false false = refl + problem3 false true true false = refl + +-- module pet-research2 ( Cat Dog Goat Rabbit : Set ) where +-- +-- open import Data.Bool hiding ( _∨_ ) +-- open import Relation.Binary +-- open import Relation.Binary.PropositionalEquality +-- +-- ¬_ : Bool → Bool +-- ¬ p = p xor true +-- +-- infixr 5 _∨_ +-- _∨_ : Bool → Bool → Bool +-- a ∨ b = ¬ ( (¬ a) ∧ (¬ b ) ) +-- +-- _=>_ : Bool → Bool → Bool +-- a => b = (¬ a ) ∨ b +-- +-- open import Data.Bool.Solver using (module xor-∧-Solver) +-- open xor-∧-Solver +-- +-- problem0' : ( Cat : Bool ) → (Cat xor Cat ) ≡ false +-- problem0' = solve 1 (λ c → (c :+ c ) := con false ) refl +-- +-- problem1' : ( Cat : Bool ) → (Cat ∧ (Cat xor true )) ≡ false +-- problem1' = solve 1 (λ c → ((c :* (c :+ con true )) ) := con false ) {!!} +-- +-- open import Data.Nat +-- :¬_ : {n : ℕ} → Polynomial n → Polynomial n +-- :¬ p = p :+ con true +-- +-- _:∨_ : {n : ℕ} → Polynomial n → Polynomial n → Polynomial n +-- a :∨ b = :¬ ( ( :¬ a ) :* ( :¬ b )) +-- +-- _:=>_ : {n : ℕ} → Polynomial n → Polynomial n → Polynomial n +-- a :=> b = ( :¬ a ) :∨ b +-- +-- _:∧_ = _:*_ +-- +-- infixr 6 _:∧_ +-- infixr 5 _:∨_ +-- +-- problem0 : ( Cat Dog Goat Rabbit : Bool ) → +-- ((( Cat ∨ Dog ) => (¬ Goat) ) ∧ ( (¬ Cat ) => ( Dog ∨ Rabbit ) ) ∧ ( ( ¬ ( Cat ∨ Goat ) ) => Rabbit ) ) +-- => (Cat ∨ Dog ∨ Goat ∨ Rabbit) ≡ true +-- problem0 = solve 4 ( λ Cat Dog Goat Rabbit → ( +-- ( ((Cat :∨ Dog ) :=> (:¬ Goat)) :∧ ( ((:¬ Cat ) :=> ( Dog :∨ Rabbit )) :∧ (( :¬ ( Cat :∨ Goat ) ) :=> Rabbit) )) +-- :=> ( Cat :∨ (Dog :∨ ( Goat :∨ Rabbit))) ) := con true ) {!!} +-- +-- problem1 : ( Cat Dog Goat Rabbit : Bool ) → +-- ((( Cat ∨ Dog ) => (¬ Goat) ) ∧ ( (¬ Cat ) => ( Dog ∨ Rabbit ) ) ∧ ( ( ¬ ( Cat ∨ Goat ) ) => Rabbit ) ) +-- => ( Goat => ( ¬ Dog )) ≡ true +-- problem1 c false false r = {!!} +-- problem1 c true false r = {!!} +-- problem1 c false true r = {!!} +-- problem1 false true true r = refl +-- problem1 true true true r = refl +-- +-- problem2 : ( Cat Dog Goat Rabbit : Bool ) → +-- ((( Cat ∨ Dog ) => (¬ Goat) ) ∧ ( (¬ Cat ) => ( Dog ∨ Rabbit ) ) ∧ ( ( ¬ ( Cat ∨ Goat ) ) => Rabbit ) ) +-- => ( Goat => Rabbit ) ≡ true +-- problem2 c d false false = {!!} +-- problem2 c d false true = {!!} +-- problem2 c d true true = {!!} +-- problem2 true d true false = refl +-- problem2 false false true false = refl +-- problem2 false true true false = refl +-- +-- problem3 : ( Cat Dog Goat Rabbit : Bool ) → +-- ((( Cat ∨ Dog ) => (¬ Goat) ) ∧ ( (¬ Cat ) => ( Dog ∨ Rabbit ) ) ∧ ( ( ¬ ( Cat ∨ Goat ) ) => Rabbit ) ) +-- => ( (¬ Rabbit ) => Cat ) ≡ true +-- problem3 false d g true = {!!} +-- problem3 true d g true = {!!} +-- problem3 true d g false = {!!} +-- problem3 false false false false = refl +-- problem3 false false true false = refl +-- problem3 false true false false = refl +-- problem3 false true true false = refl
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/automaton-in-agda/src/regex.agda Sun Jun 13 20:45:17 2021 +0900 @@ -0,0 +1,14 @@ +module regex where + +data Regex ( Σ : Set) : Set where + ε : Regex Σ -- empty + φ : Regex Σ -- fail + _* : Regex Σ → Regex Σ + _&_ : Regex Σ → Regex Σ → Regex Σ + _||_ : Regex Σ → Regex Σ → Regex Σ + <_> : Σ → Regex Σ + +infixr 40 _&_ _||_ + + +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/automaton-in-agda/src/regex1.agda Sun Jun 13 20:45:17 2021 +0900 @@ -0,0 +1,128 @@ +{-# OPTIONS --allow-unsolved-metas #-} +module regex1 where + +open import Level renaming ( suc to succ ; zero to Zero ) +open import Data.Fin +open import Data.Nat hiding ( _≟_ ) +open import Data.List hiding ( any ; [_] ) +import Data.Bool using ( Bool ; true ; false ; _∧_ ) +open import Data.Bool using ( Bool ; true ; false ; _∧_ ; _∨_ ) +open import Relation.Binary.PropositionalEquality as RBF hiding ( [_] ) +open import Relation.Nullary using (¬_; Dec; yes; no) +open import regex + +-- postulate a b c d : Set + +data In : Set where + a : In + b : In + c : In + d : In + +cmpi : (x y : In ) → Dec (x ≡ y) +cmpi a a = yes refl +cmpi b b = yes refl +cmpi c c = yes refl +cmpi d d = yes refl +cmpi a b = no (λ ()) +cmpi a c = no (λ ()) +cmpi a d = no (λ ()) +cmpi b a = no (λ ()) +cmpi b c = no (λ ()) +cmpi b d = no (λ ()) +cmpi c a = no (λ ()) +cmpi c b = no (λ ()) +cmpi c d = no (λ ()) +cmpi d a = no (λ ()) +cmpi d b = no (λ ()) +cmpi d c = no (λ ()) + +-- infixr 40 _&_ _||_ + +r1' = (< a > & < b >) & < c > --- abc +r1 = < a > & < b > & < c > --- abc +any = < a > || < b > || < c > --- a|b|c +r2 = ( any * ) & ( < a > & < b > & < c > ) -- .*abc +r3 = ( any * ) & ( < a > & < b > & < c > & < a > & < b > & < c > ) +r4 = ( < a > & < b > & < c > ) || ( < b > & < c > & < d > ) +r5 = ( any * ) & ( < a > & < b > & < c > || < b > & < c > & < d > ) + +open import nfa + +-- former ++ later ≡ x +split : {Σ : Set} → ((former : List Σ) → Bool) → ((later : List Σ) → Bool) → (x : List Σ ) → Bool +split x y [] = x [] ∧ y [] +split x y (h ∷ t) = (x [] ∧ y (h ∷ t)) ∨ + split (λ t1 → x ( h ∷ t1 )) (λ t2 → y t2 ) t + +-- tt1 : {Σ : Set} → ( P Q : List In → Bool ) → split P Q ( a ∷ b ∷ c ∷ [] ) +-- tt1 P Q = ? + +{-# TERMINATING #-} +repeat : {Σ : Set} → (List Σ → Bool) → List Σ → Bool +repeat x [] = true +repeat {Σ} x ( h ∷ t ) = split x (repeat {Σ} x) ( h ∷ t ) + +regular-language : {Σ : Set} → Regex Σ → ((x y : Σ ) → Dec (x ≡ y)) → List Σ → Bool +regular-language φ cmp _ = false +regular-language ε cmp [] = true +regular-language ε cmp (_ ∷ _) = false +regular-language (x *) cmp = repeat ( regular-language x cmp ) +regular-language (x & y) cmp = split ( λ z → (regular-language x cmp) z ) (λ z → regular-language y cmp z ) +regular-language (x || y) cmp = λ s → ( regular-language x cmp s ) ∨ ( regular-language y cmp s) +regular-language < h > cmp [] = false +regular-language < h > cmp (h1 ∷ [] ) with cmp h h1 +... | yes _ = true +... | no _ = false +regular-language < h > _ (_ ∷ _ ∷ _) = false + +test-regex : regular-language r1' cmpi ( a ∷ [] ) ≡ false +test-regex = refl + +test-regex1 : regular-language r2 cmpi ( a ∷ a ∷ b ∷ c ∷ [] ) ≡ true +test-regex1 = refl + + +test-AB→split : {Σ : Set} → {A B : List In → Bool} → split A B ( a ∷ b ∷ a ∷ [] ) ≡ ( + ( A [] ∧ B ( a ∷ b ∷ a ∷ [] ) ) ∨ + ( A ( a ∷ [] ) ∧ B ( b ∷ a ∷ [] ) ) ∨ + ( A ( a ∷ b ∷ [] ) ∧ B ( a ∷ [] ) ) ∨ + ( A ( a ∷ b ∷ a ∷ [] ) ∧ B [] ) + ) +test-AB→split {_} {A} {B} = refl + +-- from example 1.53 1 + +ex53-1 : Set +ex53-1 = (s : List In ) → regular-language ( (< a > *) & < b > & (< a > *) ) cmpi s ≡ true → {!!} -- contains exact one b + +ex53-2 : Set +ex53-2 = (s : List In ) → regular-language ( (any * ) & < b > & (any *) ) cmpi s ≡ true → {!!} -- contains at lease one b + +evenp : {Σ : Set} → List Σ → Bool +oddp : {Σ : Set} → List Σ → Bool +oddp [] = false +oddp (_ ∷ t) = evenp t + +evenp [] = true +evenp (_ ∷ t) = oddp t + +-- from example 1.53 5 +egex-even : Set +egex-even = (s : List In ) → regular-language ( ( any & any ) * ) cmpi s ≡ true → evenp s ≡ true + +test11 = regular-language ( ( any & any ) * ) cmpi (a ∷ []) +test12 = regular-language ( ( any & any ) * ) cmpi (a ∷ b ∷ []) + +-- proof-egex-even : egex-even +-- proof-egex-even [] _ = refl +-- proof-egex-even (a ∷ []) () +-- proof-egex-even (b ∷ []) () +-- proof-egex-even (c ∷ []) () +-- proof-egex-even (x ∷ x₁ ∷ s) y = proof-egex-even s {!!} + +open import derive In cmpi +open import automaton + +ra-ex = trace (regex→automaton r2) (record { state = r2 ; is-derived = unit }) ( a ∷ b ∷ c ∷ []) +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/automaton-in-agda/src/regular-concat.agda Sun Jun 13 20:45:17 2021 +0900 @@ -0,0 +1,240 @@ +module regular-concat where + +open import Level renaming ( suc to Suc ; zero to Zero ) +open import Data.List +open import Data.Nat hiding ( _≟_ ) +open import Data.Fin hiding ( _+_ ) +open import Data.Empty +open import Data.Unit +open import Data.Product +-- open import Data.Maybe +open import Relation.Nullary +open import Relation.Binary.PropositionalEquality hiding ( [_] ) +open import logic +open import nat +open import automaton +open import regular-language + +open import nfa +open import sbconst2 + +open RegularLanguage +open Automaton + +Concat-NFA : {Σ : Set} → (A B : RegularLanguage Σ ) → ((x y : states A )→ Dec (x ≡ y)) → ((x y : states B )→ Dec (x ≡ y)) + → NAutomaton (states A ∨ states B) Σ +Concat-NFA {Σ} A B equal?A equal?B = record { Nδ = δnfa ; Nend = nend } + module Concat-NFA where + δnfa : states A ∨ states B → Σ → states A ∨ states B → Bool + δnfa (case1 q) i (case1 q₁) with equal?A (δ (automaton A) q i) q₁ + ... | yes _ = true + ... | no _ = false + δnfa (case1 qa) i (case2 qb) with equal?B qb (δ (automaton B) (astart B) i) + ... | yes _ = aend (automaton A) qa + ... | no _ = false + δnfa (case2 q) i (case2 q₁) with equal?B (δ (automaton B) q i) q₁ + ... | yes _ = true + ... | no _ = false + δnfa _ i _ = false + nend : states A ∨ states B → Bool + nend (case2 q) = aend (automaton B) q + nend (case1 q) = aend (automaton A) q /\ aend (automaton B) (astart B) -- empty B case + +Concat-NFA-start : {Σ : Set} → (A B : RegularLanguage Σ ) → states A ∨ states B → ((x y : states A )→ Dec (x ≡ y)) → Bool +Concat-NFA-start A B (case1 a) equal?A with equal?A a (astart A) +... | yes _ = true +... | no _ = false +Concat-NFA-start A B (case2 b) equal?A = false + +M-Concat : {Σ : Set} → (A B : RegularLanguage Σ ) → ((states A → Bool) → Bool) → ((states B → Bool) → Bool) → RegularLanguage Σ +M-Concat {Σ} A B existsA existsB = record { + states = states A ∨ states B → Bool + ; astart = λ ab → Concat-NFA-start A B ab {!!} + ; automaton = subset-construction sbexists (Concat-NFA A B {!!} {!!} ) + } where + sbexists : (states A ∨ states B → Bool) → Bool + sbexists P = existsA ( λ a → existsB ( λ b → P (case1 a) \/ P (case2 b))) + +record Split {Σ : Set} (A : List Σ → Bool ) ( B : List Σ → Bool ) (x : List Σ ) : Set where + field + sp0 : List Σ + sp1 : List Σ + sp-concat : sp0 ++ sp1 ≡ x + prop0 : A sp0 ≡ true + prop1 : B sp1 ≡ true + +open Split + +list-empty++ : {Σ : Set} → (x y : List Σ) → x ++ y ≡ [] → (x ≡ [] ) ∧ (y ≡ [] ) +list-empty++ [] [] refl = record { proj1 = refl ; proj2 = refl } +list-empty++ [] (x ∷ y) () +list-empty++ (x ∷ x₁) y () + +open _∧_ + +open import Relation.Binary.PropositionalEquality hiding ( [_] ) + +c-split-lemma : {Σ : Set} → (A B : List Σ → Bool ) → (h : Σ) → ( t : List Σ ) → split A B (h ∷ t ) ≡ true + → ( ¬ (A [] ≡ true )) ∨ ( ¬ (B ( h ∷ t ) ≡ true) ) + → split (λ t1 → A (h ∷ t1)) B t ≡ true +c-split-lemma {Σ} A B h t eq p = sym ( begin + true + ≡⟨ sym eq ⟩ + split A B (h ∷ t ) + ≡⟨⟩ + A [] /\ B (h ∷ t) \/ split (λ t1 → A (h ∷ t1)) B t + ≡⟨ cong ( λ k → k \/ split (λ t1 → A (h ∷ t1)) B t ) (lemma-p p ) ⟩ + false \/ split (λ t1 → A (h ∷ t1)) B t + ≡⟨ bool-or-1 refl ⟩ + split (λ t1 → A (h ∷ t1)) B t + ∎ ) where + open ≡-Reasoning + lemma-p : ( ¬ (A [] ≡ true )) ∨ ( ¬ (B ( h ∷ t ) ≡ true) ) → A [] /\ B (h ∷ t) ≡ false + lemma-p (case1 ¬A ) = bool-and-1 ( ¬-bool-t ¬A ) + lemma-p (case2 ¬B ) = bool-and-2 ( ¬-bool-t ¬B ) + +split→AB : {Σ : Set} → (A B : List Σ → Bool ) → ( x : List Σ ) → split A B x ≡ true → Split A B x +split→AB {Σ} A B [] eq with bool-≡-? (A []) true | bool-≡-? (B []) true +split→AB {Σ} A B [] eq | yes eqa | yes eqb = + record { sp0 = [] ; sp1 = [] ; sp-concat = refl ; prop0 = eqa ; prop1 = eqb } +split→AB {Σ} A B [] eq | yes p | no ¬p = ⊥-elim (lemma-∧-1 eq (¬-bool-t ¬p )) +split→AB {Σ} A B [] eq | no ¬p | t = ⊥-elim (lemma-∧-0 eq (¬-bool-t ¬p )) +split→AB {Σ} A B (h ∷ t ) eq with bool-≡-? (A []) true | bool-≡-? (B (h ∷ t )) true +... | yes px | yes py = record { sp0 = [] ; sp1 = h ∷ t ; sp-concat = refl ; prop0 = px ; prop1 = py } +... | no px | _ with split→AB (λ t1 → A ( h ∷ t1 )) B t (c-split-lemma A B h t eq (case1 px) ) +... | S = record { sp0 = h ∷ sp0 S ; sp1 = sp1 S ; sp-concat = cong ( λ k → h ∷ k) (sp-concat S) ; prop0 = prop0 S ; prop1 = prop1 S } +split→AB {Σ} A B (h ∷ t ) eq | _ | no px with split→AB (λ t1 → A ( h ∷ t1 )) B t (c-split-lemma A B h t eq (case2 px) ) +... | S = record { sp0 = h ∷ sp0 S ; sp1 = sp1 S ; sp-concat = cong ( λ k → h ∷ k) (sp-concat S) ; prop0 = prop0 S ; prop1 = prop1 S } + +AB→split : {Σ : Set} → (A B : List Σ → Bool ) → ( x y : List Σ ) → A x ≡ true → B y ≡ true → split A B (x ++ y ) ≡ true +AB→split {Σ} A B [] [] eqa eqb = begin + split A B [] + ≡⟨⟩ + A [] /\ B [] + ≡⟨ cong₂ (λ j k → j /\ k ) eqa eqb ⟩ + true + ∎ where open ≡-Reasoning +AB→split {Σ} A B [] (h ∷ y ) eqa eqb = begin + split A B (h ∷ y ) + ≡⟨⟩ + A [] /\ B (h ∷ y) \/ split (λ t1 → A (h ∷ t1)) B y + ≡⟨ cong₂ (λ j k → j /\ k \/ split (λ t1 → A (h ∷ t1)) B y ) eqa eqb ⟩ + true /\ true \/ split (λ t1 → A (h ∷ t1)) B y + ≡⟨⟩ + true \/ split (λ t1 → A (h ∷ t1)) B y + ≡⟨⟩ + true + ∎ where open ≡-Reasoning +AB→split {Σ} A B (h ∷ t) y eqa eqb = begin + split A B ((h ∷ t) ++ y) + ≡⟨⟩ + A [] /\ B (h ∷ t ++ y) \/ split (λ t1 → A (h ∷ t1)) B (t ++ y) + ≡⟨ cong ( λ k → A [] /\ B (h ∷ t ++ y) \/ k ) (AB→split {Σ} (λ t1 → A (h ∷ t1)) B t y eqa eqb ) ⟩ + A [] /\ B (h ∷ t ++ y) \/ true + ≡⟨ bool-or-3 ⟩ + true + ∎ where open ≡-Reasoning + +open NAutomaton +open import Data.List.Properties + +open import finiteSet +open import finiteSetUtil + +open FiniteSet + +closed-in-concat : {Σ : Set} → (A B : RegularLanguage Σ ) → ( x : List Σ ) → isRegular (Concat (contain A) (contain B)) x ( M-Concat A B ) +closed-in-concat {Σ} A B x = ≡-Bool-func closed-in-concat→ closed-in-concat← where + afin : (A : RegularLanguage Σ ) → FiniteSet A + afin = ? + finab = (fin-∨ (afin A) (afin B)) + NFA = (Concat-NFA A B) + abmove : (q : states A ∨ states B) → (h : Σ ) → states A ∨ states B + abmove (case1 q) h = case1 (δ (automaton A) q h) + abmove (case2 q) h = case2 (δ (automaton B) q h) + lemma-nmove-ab : (q : states A ∨ states B) → (h : Σ ) → Nδ NFA q h (abmove q h) ≡ true + lemma-nmove-ab (case1 q) _ = ? -- equal?-refl (afin A) + lemma-nmove-ab (case2 q) _ = ? -- equal?-refl (afin B) + nmove : (q : states A ∨ states B) (nq : states A ∨ states B → Bool ) → (nq q ≡ true) → ( h : Σ ) → + exists finab (λ qn → nq qn /\ Nδ NFA qn h (abmove q h)) ≡ true + nmove (case1 q) nq nqt h = found finab (case1 q) ( bool-and-tt nqt (lemma-nmove-ab (case1 q) h) ) + nmove (case2 q) nq nqt h = found finab (case2 q) ( bool-and-tt nqt (lemma-nmove-ab (case2 q) h) ) + acceptB : (z : List Σ) → (q : states B) → (nq : states A ∨ states B → Bool ) → (nq (case2 q) ≡ true) → ( accept (automaton B) q z ≡ true ) + → Naccept NFA finab nq z ≡ true + acceptB [] q nq nqt fb = lemma8 where + lemma8 : exists finab ( λ q → nq q /\ Nend NFA q ) ≡ true + lemma8 = found finab (case2 q) ( bool-and-tt nqt fb ) + acceptB (h ∷ t ) q nq nq=q fb = acceptB t (δ (automaton B) q h) (Nmoves NFA finab nq h) (nmove (case2 q) nq nq=q h) fb + + acceptA : (y z : List Σ) → (q : states A) → (nq : states A ∨ states B → Bool ) → (nq (case1 q) ≡ true) + → ( accept (automaton A) q y ≡ true ) → ( accept (automaton B) (astart B) z ≡ true ) + → Naccept NFA finab nq (y ++ z) ≡ true + acceptA [] [] q nq nqt fa fb = found finab (case1 q) (bool-and-tt nqt (bool-and-tt fa fb )) + acceptA [] (h ∷ z) q nq nq=q fa fb = acceptB z nextb (Nmoves NFA finab nq h) lemma70 fb where + nextb : states B + nextb = δ (automaton B) (astart B) h + lemma70 : exists finab (λ qn → nq qn /\ Nδ NFA qn h (case2 nextb)) ≡ true + lemma70 = found finab (case1 q) ( bool-and-tt nq=q (bool-and-tt fa (lemma-nmove-ab (case2 (astart B)) h) )) + acceptA (h ∷ t) z q nq nq=q fa fb = acceptA t z (δ (automaton A) q h) (Nmoves NFA finab nq h) (nmove (case1 q) nq nq=q h) fa fb where + + acceptAB : Split (contain A) (contain B) x + → Naccept NFA finab (equal? finab (case1 (astart A))) x ≡ true + acceptAB S = subst ( λ k → Naccept NFA finab (equal? finab (case1 (astart A))) k ≡ true ) ( sp-concat S ) + (acceptA (sp0 S) (sp1 S) (astart A) (equal? finab (case1 (astart A))) ? (prop0 S) (prop1 S) ) + + closed-in-concat→ : Concat (contain A) (contain B) x ≡ true → contain (M-Concat A B) x ≡ true + closed-in-concat→ concat with split→AB (contain A) (contain B) x concat + ... | S = begin + accept (subset-construction finab NFA (case1 (astart A))) (Concat-NFA-start A B ) x + ≡⟨ ≡-Bool-func (subset-construction-lemma← finab NFA (case1 (astart A)) x ) + (subset-construction-lemma→ finab NFA (case1 (astart A)) x ) ⟩ + Naccept NFA finab (equal? finab (case1 (astart A))) x + ≡⟨ acceptAB S ⟩ + true + ∎ where open ≡-Reasoning + + open Found + + ab-case : (q : states A ∨ states B ) → (qa : states A ) → (x : List Σ ) → Set + ab-case (case1 qa') qa x = qa' ≡ qa + ab-case (case2 qb) qa x = ¬ ( accept (automaton B) qb x ≡ true ) + + contain-A : (x : List Σ) → (nq : states A ∨ states B → Bool ) → (fn : Naccept NFA finab nq x ≡ true ) + → (qa : states A ) → ( (q : states A ∨ states B) → nq q ≡ true → ab-case q qa x ) + → split (accept (automaton A) qa ) (contain B) x ≡ true + contain-A [] nq fn qa cond with found← finab fn + ... | S with found-q S | inspect found-q S | cond (found-q S) (bool-∧→tt-0 (found-p S)) + ... | case1 qa' | record { eq = refl } | refl = bool-∧→tt-1 (found-p S) + ... | case2 qb | record { eq = refl } | ab = ⊥-elim ( ab (bool-∧→tt-1 (found-p S))) + contain-A (h ∷ t) nq fn qa cond with bool-≡-? ((aend (automaton A) qa) /\ accept (automaton B) (δ (automaton B) (astart B) h) t ) true + ... | yes eq = bool-or-41 eq + ... | no ne = bool-or-31 (contain-A t (Nmoves NFA finab nq h) fn (δ (automaton A) qa h) lemma11 ) where + lemma11 : (q : states A ∨ states B) → exists finab (λ qn → nq qn /\ Nδ NFA qn h q) ≡ true → ab-case q (δ (automaton A) qa h) t + lemma11 (case1 qa') ex with found← finab ex + ... | S with found-q S | inspect found-q S | cond (found-q S) (bool-∧→tt-0 (found-p S)) + ... | case1 qa | record { eq = refl } | refl = sym ( equal→refl (afin A) ( bool-∧→tt-1 (found-p S) )) -- continued A case + ... | case2 qb | record { eq = refl } | nb with bool-∧→tt-1 (found-p S) -- δnfa (case2 q) i (case1 q₁) is false + ... | () + lemma11 (case2 qb) ex with found← finab ex + ... | S with found-q S | inspect found-q S | cond (found-q S) (bool-∧→tt-0 (found-p S)) + lemma11 (case2 qb) ex | S | case2 qb' | record { eq = refl } | nb = contra-position lemma13 nb where -- continued B case should fail + lemma13 : accept (automaton B) qb t ≡ true → accept (automaton B) qb' (h ∷ t) ≡ true + lemma13 fb = subst (λ k → accept (automaton B) k t ≡ true ) (sym (equal→refl (afin B) (bool-∧→tt-1 (found-p S)))) fb + lemma11 (case2 qb) ex | S | case1 qa | record { eq = refl } | refl with bool-∧→tt-1 (found-p S) + ... | eee = contra-position lemma12 ne where -- starting B case should fail + lemma12 : accept (automaton B) qb t ≡ true → aend (automaton A) qa /\ accept (automaton B) (δ (automaton B) (astart B) h) t ≡ true + lemma12 fb = bool-and-tt (bool-∧→tt-0 eee) (subst ( λ k → accept (automaton B) k t ≡ true ) (equal→refl (afin B) (bool-∧→tt-1 eee) ) fb ) + + lemma10 : Naccept NFA finab (equal? finab (case1 (astart A))) x ≡ true → split (contain A) (contain B) x ≡ true + lemma10 CC = contain-A x (Concat-NFA-start A B ) CC (astart A) lemma15 where + lemma15 : (q : states A ∨ states B) → Concat-NFA-start A B q ≡ true → ab-case q (astart A) x + lemma15 q nq=t with equal→refl finab nq=t + ... | refl = refl + + closed-in-concat← : contain (M-Concat A B) x ≡ true → Concat (contain A) (contain B) x ≡ true + closed-in-concat← C with subset-construction-lemma← finab NFA (case1 (astart A)) x C + ... | CC = lemma10 CC + + + +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/automaton-in-agda/src/regular-language.agda Sun Jun 13 20:45:17 2021 +0900 @@ -0,0 +1,87 @@ +module regular-language where + +open import Level renaming ( suc to Suc ; zero to Zero ) +open import Data.List +open import Data.Nat hiding ( _≟_ ) +open import Data.Fin hiding ( _+_ ) +open import Data.Empty +open import Data.Unit +open import Data.Product +-- open import Data.Maybe +open import Relation.Nullary +open import Relation.Binary.PropositionalEquality hiding ( [_] ) +open import logic +open import nat +open import automaton + +language : { Σ : Set } → Set +language {Σ} = List Σ → Bool + +language-L : { Σ : Set } → Set +language-L {Σ} = List (List Σ) + +open Automaton + +record RegularLanguage ( Σ : Set ) : Set (Suc Zero) where + field + states : Set + astart : states + automaton : Automaton states Σ + contain : List Σ → Bool + contain x = accept automaton astart x + +Union : {Σ : Set} → ( A B : language {Σ} ) → language {Σ} +Union {Σ} A B x = (A x ) \/ (B x) + +split : {Σ : Set} → (List Σ → Bool) + → ( List Σ → Bool) → List Σ → Bool +split x y [] = x [] /\ y [] +split x y (h ∷ t) = (x [] /\ y (h ∷ t)) \/ + split (λ t1 → x ( h ∷ t1 )) (λ t2 → y t2 ) t + +Concat : {Σ : Set} → ( A B : language {Σ} ) → language {Σ} +Concat {Σ} A B = split A B + +{-# TERMINATING #-} +Star : {Σ : Set} → ( A : language {Σ} ) → language {Σ} +Star {Σ} A = split A ( Star {Σ} A ) + +open import automaton-ex + +test-AB→split : {Σ : Set} → {A B : List In2 → Bool} → split A B ( i0 ∷ i1 ∷ i0 ∷ [] ) ≡ ( + ( A [] /\ B ( i0 ∷ i1 ∷ i0 ∷ [] ) ) \/ + ( A ( i0 ∷ [] ) /\ B ( i1 ∷ i0 ∷ [] ) ) \/ + ( A ( i0 ∷ i1 ∷ [] ) /\ B ( i0 ∷ [] ) ) \/ + ( A ( i0 ∷ i1 ∷ i0 ∷ [] ) /\ B [] ) + ) +test-AB→split {_} {A} {B} = refl + +open RegularLanguage +isRegular : {Σ : Set} → (A : language {Σ} ) → ( x : List Σ ) → (r : RegularLanguage Σ ) → Set +isRegular A x r = A x ≡ contain r x + +-- postulate +-- fin-× : {A B : Set} → { a b : ℕ } → FiniteSet A {a} → FiniteSet B {b} → FiniteSet (A × B) {a * b} + +M-Union : {Σ : Set} → (A B : RegularLanguage Σ ) → RegularLanguage Σ +M-Union {Σ} A B = record { + states = states A × states B + ; astart = ( astart A , astart B ) + ; automaton = record { + δ = λ q x → ( δ (automaton A) (proj₁ q) x , δ (automaton B) (proj₂ q) x ) + ; aend = λ q → ( aend (automaton A) (proj₁ q) \/ aend (automaton B) (proj₂ q) ) + } + } + +closed-in-union : {Σ : Set} → (A B : RegularLanguage Σ ) → ( x : List Σ ) → isRegular (Union (contain A) (contain B)) x ( M-Union A B ) +closed-in-union A B [] = lemma where + lemma : aend (automaton A) (astart A) \/ aend (automaton B) (astart B) ≡ + aend (automaton A) (astart A) \/ aend (automaton B) (astart B) + lemma = refl +closed-in-union {Σ} A B ( h ∷ t ) = lemma1 t ((δ (automaton A) (astart A) h)) ((δ (automaton B) (astart B) h)) where + lemma1 : (t : List Σ) → (qa : states A ) → (qb : states B ) → + accept (automaton A) qa t \/ accept (automaton B) qb t + ≡ accept (automaton (M-Union A B)) (qa , qb) t + lemma1 [] qa qb = refl + lemma1 (h ∷ t ) qa qb = lemma1 t ((δ (automaton A) qa h)) ((δ (automaton B) qb h)) +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/automaton-in-agda/src/root2.agda Sun Jun 13 20:45:17 2021 +0900 @@ -0,0 +1,100 @@ +module root2 where + +open import Data.Nat +open import Data.Nat.Properties +open import Data.Empty +open import Data.Unit using (⊤ ; tt) +open import Relation.Nullary +open import Relation.Binary.PropositionalEquality +open import Relation.Binary.Definitions + +open import gcd +open import even +open import nat + +record Rational : Set where + field + i j : ℕ + coprime : gcd i j ≡ 1 + +even→gcd=2 : {n : ℕ} → even n → n > 0 → gcd n 2 ≡ 2 +even→gcd=2 {suc (suc zero)} en (s≤s z≤n) = refl +even→gcd=2 {suc (suc (suc (suc n)))} en (s≤s z≤n) = begin + gcd (suc (suc (suc (suc n)))) 2 ≡⟨⟩ + gcd (suc (suc n)) 2 ≡⟨ even→gcd=2 {suc (suc n)} en (s≤s z≤n) ⟩ + 2 ∎ where open ≡-Reasoning + +even^2 : {n : ℕ} → even ( n * n ) → even n +even^2 {n} en with even? n +... | yes y = y +... | no ne = ⊥-elim ( odd4 ((2 * m) + 2 * m * suc (2 * m)) (n+even {2 * m} {2 * m * suc (2 * m)} ee3 ee4) (subst (λ k → even k) ee2 en )) where + m : ℕ + m = Odd.j ( odd3 n ne ) + ee3 : even (2 * m) + ee3 = subst (λ k → even k ) (*-comm m 2) (n*even {m} {2} tt ) + ee4 : even ((2 * m) * suc (2 * m)) + ee4 = even*n {(2 * m)} {suc (2 * m)} (even*n {2} {m} tt ) + ee2 : n * n ≡ suc (2 * m) + ((2 * m) * (suc (2 * m) )) + ee2 = begin n * n ≡⟨ cong ( λ k → k * k) (Odd.is-twice (odd3 n ne)) ⟩ + suc (2 * m) * suc (2 * m) ≡⟨ *-distribʳ-+ (suc (2 * m)) 1 ((2 * m) ) ⟩ + (1 * suc (2 * m)) + 2 * m * suc (2 * m) ≡⟨ cong (λ k → k + 2 * m * suc (2 * m)) (begin + suc m + 1 * m + 0 * (suc m + 1 * m ) ≡⟨ +-comm (suc m + 1 * m) 0 ⟩ + suc m + 1 * m ≡⟨⟩ + suc (2 * m) + ∎) ⟩ suc (2 * m) + 2 * m * suc (2 * m) ∎ where open ≡-Reasoning + +e3 : {i j : ℕ } → 2 * i ≡ 2 * j → i ≡ j +e3 {zero} {zero} refl = refl +e3 {suc x} {suc y} eq with <-cmp x y +... | tri< a ¬b ¬c = ⊥-elim ( nat-≡< eq (s≤s (<-trans (<-plus a) (<-plus-0 (s≤s (<-plus a )))))) +... | tri≈ ¬a b ¬c = cong suc b +... | tri> ¬a ¬b c = ⊥-elim ( nat-≡< (sym eq) (s≤s (<-trans (<-plus c) (<-plus-0 (s≤s (<-plus c )))))) + +open Factor + +root2-irrational : ( n m : ℕ ) → n > 1 → m > 1 → 2 * n * n ≡ m * m → ¬ (gcd n m ≡ 1) +root2-irrational n m n>1 m>1 2nm = rot13 ( gcd-gt n n m m 2 f2 f2 f2 fm {!!} {!!} {!!} {!!}) where + rot13 : {m : ℕ } → Dividable 2 m → m ≡ 1 → ⊥ + rot13 d refl with Dividable.is-factor d + ... | t = {!!} + rot11 : {m : ℕ } → even m → Factor 2 m + rot11 {zero} em = record { factor = 0 ; remain = 0 ; is-factor = refl } + rot11 {suc zero} () + rot11 {suc (suc m) } em = record { factor = suc (factor fc ) ; remain = remain fc ; is-factor = isfc } where + fc : Factor 2 m + fc = rot11 {m} em + isfc : suc (factor fc) * 2 + remain fc ≡ suc (suc m) + isfc = begin + suc (factor fc) * 2 + remain fc ≡⟨ cong (λ k → k + remain fc) (*-distribʳ-+ 2 1 (factor fc)) ⟩ + ((1 * 2) + (factor fc)* 2 ) + remain fc ≡⟨⟩ + ((1 + 1) + (factor fc)* 2 ) + remain fc ≡⟨ cong (λ k → k + remain fc) (+-assoc 1 1 _ ) ⟩ + (1 + (1 + (factor fc)* 2 )) + remain fc ≡⟨⟩ + suc (suc ((factor fc * 2) + remain fc )) ≡⟨ cong (λ x → suc (suc x)) (is-factor fc) ⟩ + suc (suc m) ∎ where open ≡-Reasoning + rot5 : {n : ℕ} → n > 1 → n > 0 + rot5 {n} lt = <-trans a<sa lt + rot1 : even ( m * m ) + rot1 = subst (λ k → even k ) rot4 (n*even {n * n} {2} tt ) where + rot4 : (n * n) * 2 ≡ m * m + rot4 = begin + (n * n) * 2 ≡⟨ *-comm (n * n) 2 ⟩ + 2 * ( n * n ) ≡⟨ sym (*-assoc 2 n n) ⟩ + 2 * n * n ≡⟨ 2nm ⟩ + m * m ∎ where open ≡-Reasoning + E : Even m + E = e2 m ( even^2 {m} ( rot1 )) + rot2 : 2 * n * n ≡ 2 * Even.j E * m + rot2 = subst (λ k → 2 * n * n ≡ k * m ) (Even.is-twice E) 2nm + rot3 : n * n ≡ Even.j E * m + rot3 = e3 ( begin + 2 * (n * n) ≡⟨ sym (*-assoc 2 n _) ⟩ + 2 * n * n ≡⟨ rot2 ⟩ + 2 * Even.j E * m ≡⟨ *-assoc 2 (Even.j E) m ⟩ + 2 * (Even.j E * m) ∎ ) where open ≡-Reasoning + rot7 : even n + rot7 = even^2 {n} (subst (λ k → even k) (sym rot3) ((n*even {Even.j E} {m} ( even^2 {m} ( rot1 ))))) + f2 : Factor 2 n + f2 = rot11 rot7 + fm : Factor 2 m + fm = record { factor = Even.j E ; remain = 0 ; is-factor = {!!} } +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/automaton-in-agda/src/sbconst2.agda Sun Jun 13 20:45:17 2021 +0900 @@ -0,0 +1,55 @@ +module sbconst2 where + +open import Level renaming ( suc to succ ; zero to Zero ) +open import Data.Nat +open import Data.Fin +open import Data.List + +open import automaton +open import nfa +open import logic +open NAutomaton +open Automaton +open import Relation.Binary.PropositionalEquality hiding ( [_] ) + +open Bool + +δconv : { Q : Set } { Σ : Set } → ( ( Q → Bool ) → Bool ) → ( nδ : Q → Σ → Q → Bool ) → (f : Q → Bool) → (i : Σ) → (Q → Bool) +δconv {Q} { Σ} exists nδ f i q = exists ( λ r → f r /\ nδ r i q ) + +subset-construction : { Q : Set } { Σ : Set } → + ( ( Q → Bool ) → Bool ) → + (NAutomaton Q Σ ) → (Automaton (Q → Bool) Σ ) +subset-construction {Q} { Σ} exists NFA = record { + δ = λ q x → δconv exists ( Nδ NFA ) q x + ; aend = λ f → exists ( λ q → f q /\ Nend NFA q ) + } + +test4 = subset-construction existsS1 am2 + +test51 = accept test4 start1 ( i0 ∷ i1 ∷ i0 ∷ [] ) +test61 = accept test4 start1 ( i1 ∷ i1 ∷ i1 ∷ [] ) + +subset-construction-lemma→ : { Q : Set } { Σ : Set } { n : ℕ } → (exists : ( Q → Bool ) → Bool ) → + (NFA : NAutomaton Q Σ ) → (astart : Q → Bool ) + → (x : List Σ) + → Naccept NFA exists astart x ≡ true + → accept ( subset-construction exists NFA ) astart x ≡ true +subset-construction-lemma→ {Q} {Σ} {n} exists NFA astart x naccept = lemma1 x astart naccept where + lemma1 : (x : List Σ) → ( states : Q → Bool ) + → Naccept NFA exists states x ≡ true + → accept ( subset-construction exists NFA ) states x ≡ true + lemma1 [] states naccept = naccept + lemma1 (h ∷ t ) states naccept = lemma1 t (δconv exists (Nδ NFA) states h) naccept + +subset-construction-lemma← : { Q : Set } { Σ : Set } { n : ℕ } → (exists : ( Q → Bool ) → Bool ) → + (NFA : NAutomaton Q Σ ) → (astart : Q → Bool ) + → (x : List Σ) + → accept ( subset-construction exists NFA ) astart x ≡ true + → Naccept NFA exists astart x ≡ true +subset-construction-lemma← {Q} {Σ} {n} exists NFA astart x saccept = lemma2 x astart saccept where + lemma2 : (x : List Σ) → ( states : Q → Bool ) + → accept ( subset-construction exists NFA ) states x ≡ true + → Naccept NFA exists states x ≡ true + lemma2 [] states saccept = saccept + lemma2 (h ∷ t ) states saccept = lemma2 t (δconv exists (Nδ NFA) states h) saccept
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/automaton-in-agda/src/turing.agda Sun Jun 13 20:45:17 2021 +0900 @@ -0,0 +1,129 @@ +{-# OPTIONS --allow-unsolved-metas #-} +module turing where + +open import Level renaming ( suc to succ ; zero to Zero ) +open import Data.Nat -- hiding ( erase ) +open import Data.List +open import Data.Maybe hiding ( map ) +open import Data.Bool using ( Bool ; true ; false ) renaming ( not to negate ) +open import Relation.Binary.PropositionalEquality hiding ( [_] ) +open import Relation.Nullary using (¬_; Dec; yes; no) +open import Level renaming ( suc to succ ; zero to Zero ) +open import Data.Product hiding ( map ) + + +data Write ( Σ : Set ) : Set where + write : Σ → Write Σ + wnone : Write Σ + -- erase write tnone + +data Move : Set where + left : Move + right : Move + mnone : Move + +-- at tδ both stack is poped + +-- write S push S , push SR +-- erase push SL , push tone +-- none push SL , push SR +-- left push SR , pop +-- right pop , push SL + +{-# TERMINATING #-} +move : {Q Σ : Set } → { tnone : Σ} → {tδ : Q → Σ → Q × ( Write Σ ) × Move } → (q : Q ) ( L : List Σ ) ( L : List Σ ) → ( Q × List Σ × List Σ ) +move {Q} {Σ} {tnone} {tδ} q L [] = move {Q} {Σ} {tnone} {tδ} q L ( tnone ∷ [] ) +move {Q} {Σ} {tnone} {tδ} q [] R = move {Q} {Σ} {tnone} {tδ} q ( tnone ∷ [] ) R +move {Q} {Σ} {tnone} {tδ} q ( LH ∷ LT ) ( RH ∷ RT ) with tδ q LH +... | nq , write x , left = ( nq , ( RH ∷ x ∷ LT ) , RT ) +... | nq , write x , right = ( nq , LT , ( x ∷ RH ∷ RT ) ) +... | nq , write x , mnone = ( nq , ( x ∷ LT ) , ( RH ∷ RT ) ) +... | nq , wnone , left = ( nq , ( RH ∷ LH ∷ LT ) , RT ) +... | nq , wnone , right = ( nq , LT , ( LH ∷ RH ∷ RT ) ) +... | nq , wnone , mnone = ( nq , ( LH ∷ LT ) , ( RH ∷ RT ) ) +{-# TERMINATING #-} +move-loop : {Q Σ : Set } → {tend : Q → Bool} → { tnone : Σ} → {tδ : Q → Σ → Q × ( Write Σ ) × Move } + → (q : Q ) ( L : List Σ ) ( L : List Σ ) → ( Q × List Σ × List Σ ) +move-loop {Q} {Σ} {tend} {tnone} {tδ} q L R with tend q +... | true = ( q , L , R ) +... | flase = move-loop {Q} {Σ} {tend} {tnone} {tδ} ( proj₁ next ) ( proj₁ ( proj₂ next ) ) ( proj₂ ( proj₂ next ) ) + where + next = move {Q} {Σ} {tnone} {tδ} q L R + +{-# TERMINATING #-} +move0 : {Q Σ : Set } ( tend : Q → Bool ) (tnone : Σ ) (tδ : Q → Σ → Q × ( Write Σ ) × Move) + (q : Q ) ( L : List Σ ) ( L : List Σ ) → ( Q × List Σ × List Σ ) +move0 tend tnone tδ q L R with tend q +... | true = ( q , L , R ) +move0 tend tnone tδ q L [] | false = move0 tend tnone tδ q L ( tnone ∷ [] ) +move0 tend tnone tδ q [] R | false = move0 tend tnone tδ q ( tnone ∷ [] ) R +move0 tend tnone tδ q ( LH ∷ LT ) ( RH ∷ RT ) | false with tδ q LH +... | nq , write x , left = move0 tend tnone tδ nq ( RH ∷ x ∷ LT ) RT +... | nq , write x , right = move0 tend tnone tδ nq LT ( x ∷ RH ∷ RT ) +... | nq , write x , mnone = move0 tend tnone tδ nq ( x ∷ LT ) ( RH ∷ RT ) +... | nq , wnone , left = move0 tend tnone tδ nq ( RH ∷ LH ∷ LT ) RT +... | nq , wnone , right = move0 tend tnone tδ nq LT ( LH ∷ RH ∷ RT ) +... | nq , wnone , mnone = move0 tend tnone tδ nq ( LH ∷ LT ) ( RH ∷ RT ) + +record Turing ( Q : Set ) ( Σ : Set ) + : Set where + field + tδ : Q → Σ → Q × ( Write Σ ) × Move + tstart : Q + tend : Q → Bool + tnone : Σ + taccept : List Σ → ( Q × List Σ × List Σ ) + taccept L = move0 tend tnone tδ tstart L [] + +data CopyStates : Set where + s1 : CopyStates + s2 : CopyStates + s3 : CopyStates + s4 : CopyStates + s5 : CopyStates + H : CopyStates + + +Copyδ : CopyStates → ℕ → CopyStates × ( Write ℕ ) × Move +Copyδ s1 0 = H , wnone , mnone +Copyδ s1 1 = s2 , write 0 , right +Copyδ s2 0 = s3 , write 0 , right +Copyδ s2 1 = s2 , write 1 , right +Copyδ s3 0 = s4 , write 1 , left +Copyδ s3 1 = s3 , write 1 , right +Copyδ s4 0 = s5 , write 0 , left +Copyδ s4 1 = s4 , write 1 , left +Copyδ s5 0 = s1 , write 1 , right +Copyδ s5 1 = s5 , write 1 , left +Copyδ H _ = H , wnone , mnone +Copyδ _ (suc (suc _)) = H , wnone , mnone + +copyMachine : Turing CopyStates ℕ +copyMachine = record { + tδ = Copyδ + ; tstart = s1 + ; tend = tend + ; tnone = 0 + } where + tend : CopyStates → Bool + tend H = true + tend _ = false + +test1 : CopyStates × ( List ℕ ) × ( List ℕ ) +test1 = Turing.taccept copyMachine ( 1 ∷ 1 ∷ 0 ∷ 0 ∷ 0 ∷ [] ) + +test2 : ℕ → CopyStates × ( List ℕ ) × ( List ℕ ) +test2 n = loop n (Turing.tstart copyMachine) ( 1 ∷ 1 ∷ 0 ∷ 0 ∷ 0 ∷ [] ) [] + where + loop : ℕ → CopyStates → ( List ℕ ) → ( List ℕ ) → CopyStates × ( List ℕ ) × ( List ℕ ) + loop zero q L R = ( q , L , R ) + loop (suc n) q L R = loop n ( proj₁ t1 ) ( proj₁ ( proj₂ t1 ) ) ( proj₂ ( proj₂ t1 ) ) + where + t1 = move {CopyStates} {ℕ} {0} {Copyδ} q L R + +-- testn = map (\ n -> test2 n) ( 0 ∷ 1 ∷ 2 ∷ 3 ∷ 4 ∷ 5 ∷ 6 ∷ [] ) + +testn : ℕ → List ( CopyStates × ( List ℕ ) × ( List ℕ ) ) +testn 0 = test2 0 ∷ [] +testn (suc n) = test2 n ∷ testn n +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/automaton-in-agda/src/utm.agda Sun Jun 13 20:45:17 2021 +0900 @@ -0,0 +1,250 @@ +module utm where + +open import turing +open import Data.Product +open import Data.Bool +open import Data.List +open import Data.Nat + +data utmStates : Set where + reads : utmStates + read0 : utmStates + read1 : utmStates + read2 : utmStates + read3 : utmStates + read4 : utmStates + read5 : utmStates + read6 : utmStates + + loc0 : utmStates + loc1 : utmStates + loc2 : utmStates + loc3 : utmStates + loc4 : utmStates + loc5 : utmStates + loc6 : utmStates + + fetch0 : utmStates + fetch1 : utmStates + fetch2 : utmStates + fetch3 : utmStates + fetch4 : utmStates + fetch5 : utmStates + fetch6 : utmStates + fetch7 : utmStates + + print0 : utmStates + print1 : utmStates + print2 : utmStates + print3 : utmStates + print4 : utmStates + print5 : utmStates + print6 : utmStates + print7 : utmStates + + mov0 : utmStates + mov1 : utmStates + mov2 : utmStates + mov3 : utmStates + mov4 : utmStates + mov5 : utmStates + mov6 : utmStates + + tidy0 : utmStates + tidy1 : utmStates + halt : utmStates + +data utmΣ : Set where + ０ : utmΣ + １ : utmΣ + B : utmΣ + * : utmΣ + $ : utmΣ + ^ : utmΣ + X : utmΣ + Y : utmΣ + Z : utmΣ + ＠ : utmΣ + b : utmΣ + +utmδ : utmStates → utmΣ → utmStates × (Write utmΣ) × Move +utmδ reads x = read0 , wnone , mnone +utmδ read0 * = read1 , write * , left +utmδ read0 x = read0 , write x , right +utmδ read1 x = read2 , write ＠ , right +utmδ read2 ^ = read3 , write ^ , right +utmδ read2 x = read2 , write x , right +utmδ read3 ０ = read4 , write ０ , left +utmδ read3 １ = read5 , write １ , left +utmδ read3 b = read6 , write b , left +utmδ read4 ＠ = loc0 , write ０ , right +utmδ read4 x = read4 , write x , left +utmδ read5 ＠ = loc0 , write １ , right +utmδ read5 x = read5 , write x , left +utmδ read6 ＠ = loc0 , write B , right +utmδ read6 x = read6 , write x , left +utmδ loc0 ０ = loc0 , write X , left +utmδ loc0 １ = loc0 , write Y , left +utmδ loc0 B = loc0 , write Z , left +utmδ loc0 $ = loc1 , write $ , right +utmδ loc0 x = loc0 , write x , left +utmδ loc1 X = loc2 , write ０ , right +utmδ loc1 Y = loc3 , write １ , right +utmδ loc1 Z = loc4 , write B , right +utmδ loc1 * = fetch0 , write * , right +utmδ loc1 x = loc1 , write x , right +utmδ loc2 ０ = loc5 , write X , right +utmδ loc2 １ = loc6 , write Y , right +utmδ loc2 B = loc6 , write Z , right +utmδ loc2 x = loc2 , write x , right +utmδ loc3 １ = loc5 , write Y , right +utmδ loc3 ０ = loc6 , write X , right +utmδ loc3 B = loc6 , write Z , right +utmδ loc3 x = loc3 , write x , right +utmδ loc4 B = loc5 , write Z , right +utmδ loc4 ０ = loc6 , write X , right +utmδ loc4 １ = loc6 , write Y , right +utmδ loc4 x = loc4 , write x , right +utmδ loc5 $ = loc1 , write $ , right +utmδ loc5 x = loc5 , write x , left +utmδ loc6 $ = halt , write $ , right +utmδ loc6 * = loc0 , write * , left +utmδ loc6 x = loc6 , write x , right +utmδ fetch0 ０ = fetch1 , write X , left +utmδ fetch0 １ = fetch2 , write Y , left +utmδ fetch0 B = fetch3 , write Z , left +utmδ fetch0 x = fetch0 , write x , right +utmδ fetch1 $ = fetch4 , write $ , right +utmδ fetch1 x = fetch1 , write x , left +utmδ fetch2 $ = fetch5 , write $ , right +utmδ fetch2 x = fetch2 , write x , left +utmδ fetch3 $ = fetch6 , write $ , right +utmδ fetch3 x = fetch3 , write x , left +utmδ fetch4 ０ = fetch7 , write X , right +utmδ fetch4 １ = fetch7 , write X , right +utmδ fetch4 B = fetch7 , write X , right +utmδ fetch4 * = print0 , write * , left +utmδ fetch4 x = fetch4 , write x , right +utmδ fetch5 ０ = fetch7 , write Y , right +utmδ fetch5 １ = fetch7 , write Y , right +utmδ fetch5 B = fetch7 , write Y , right +utmδ fetch5 * = print0 , write * , left +utmδ fetch5 x = fetch5 , write x , right +utmδ fetch6 ０ = fetch7 , write Z , right +utmδ fetch6 １ = fetch7 , write Z , right +utmδ fetch6 B = fetch7 , write Z , right +utmδ fetch6 * = print0 , write * , left +utmδ fetch6 x = fetch6 , write x , right +utmδ fetch7 * = fetch0 , write * , right +utmδ fetch7 x = fetch7 , write x , right +utmδ print0 X = print1 , write X , right +utmδ print0 Y = print2 , write Y , right +utmδ print0 Z = print3 , write Z , right +utmδ print1 ^ = print4 , write ^ , right +utmδ print1 x = print1 , write x , right +utmδ print2 ^ = print5 , write ^ , right +utmδ print2 x = print2 , write x , right +utmδ print3 ^ = print6 , write ^ , right +utmδ print3 x = print3 , write x , right +utmδ print4 x = print7 , write ０ , left +utmδ print5 x = print7 , write １ , left +utmδ print6 x = print7 , write B , left +utmδ print7 X = mov0 , write X , right +utmδ print7 Y = mov1 , write Y , right +utmδ print7 x = print7 , write x , left +utmδ mov0 ^ = mov2 , write ^ , left +utmδ mov0 x = mov0 , write x , right +utmδ mov1 ^ = mov3 , write ^ , right +utmδ mov1 x = mov1 , write x , right +utmδ mov2 ０ = mov4 , write ^ , right +utmδ mov2 １ = mov5 , write ^ , right +utmδ mov2 B = mov6 , write ^ , right +utmδ mov3 ０ = mov4 , write ^ , left +utmδ mov3 １ = mov5 , write ^ , left +utmδ mov3 B = mov6 , write ^ , left +utmδ mov4 ^ = tidy0 , write ０ , left +utmδ mov5 ^ = tidy0 , write １ , left +utmδ mov6 ^ = tidy0 , write B , left +utmδ tidy0 $ = tidy1 , write $ , left +utmδ tidy0 x = tidy0 , write x , left +utmδ tidy1 X = tidy1 , write ０ , left +utmδ tidy1 Y = tidy1 , write １ , left +utmδ tidy1 Z = tidy1 , write B , left +utmδ tidy1 $ = reads , write $ , right +utmδ tidy1 x = tidy1 , write x , left +utmδ _ x = halt , write x , mnone + +U-TM : Turing utmStates utmΣ +U-TM = record { + tδ = utmδ + ; tstart = read0 + ; tend = tend + ; tnone = b + } where + tend : utmStates → Bool + tend halt = true + tend _ = false + +-- Copyδ : CopyStates → ℕ → CopyStates × ( Write ℕ ) × Move +-- Copyδ s1 0 = H , wnone , mnone +-- Copyδ s1 1 = s2 , write 0 , right +-- Copyδ s2 0 = s3 , write 0 , right +-- Copyδ s2 1 = s2 , write 1 , right +-- Copyδ s3 0 = s4 , write 1 , left +-- Copyδ s3 1 = s3 , write 1 , right +-- Copyδ s4 0 = s5 , write 0 , left +-- Copyδ s4 1 = s4 , write 1 , left +-- Copyδ s5 0 = s1 , write 1 , right +-- Copyδ s5 1 = s5 , write 1 , left +-- Copyδ H _ = H , wnone , mnone +-- Copyδ _ (suc (suc _)) = H , wnone , mnone + +Copyδ-encode : List utmΣ +Copyδ-encode = + ０ ∷ ０ ∷ １ ∷ ０ ∷ １ ∷ １ ∷ ０ ∷ ０ ∷ ０ ∷ ０ ∷ -- s1 0 = H , wnone , mnone + * ∷ ０ ∷ ０ ∷ １ ∷ １ ∷ ０ ∷ １ ∷ ０ ∷ ０ ∷ ０ ∷ １ ∷ -- s1 1 = s2 , write 0 , right + * ∷ ０ ∷ １ ∷ ０ ∷ ０ ∷ ０ ∷ １ ∷ １ ∷ ０ ∷ ０ ∷ １ ∷ -- s2 0 = s3 , write 0 , right + * ∷ ０ ∷ １ ∷ ０ ∷ １ ∷ ０ ∷ １ ∷ ０ ∷ １ ∷ ０ ∷ １ ∷ -- s2 1 = s2 , write 1 , right + * ∷ ０ ∷ １ ∷ １ ∷ ０ ∷ １ ∷ ０ ∷ ０ ∷ １ ∷ ０ ∷ ０ ∷ -- s3 0 = s4 , write 1 , left + * ∷ ０ ∷ １ ∷ １ ∷ １ ∷ ０ ∷ １ ∷ １ ∷ １ ∷ ０ ∷ １ ∷ -- s3 1 = s3 , write 1 , right + * ∷ １ ∷ ０ ∷ ０ ∷ ０ ∷ １ ∷ ０ ∷ １ ∷ ０ ∷ ０ ∷ ０ ∷ -- s4 0 = s5 , write 0 , left + * ∷ １ ∷ ０ ∷ ０ ∷ １ ∷ １ ∷ ０ ∷ ０ ∷ １ ∷ ０ ∷ ０ ∷ -- s4 1 = s4 , write 1 , left + * ∷ １ ∷ ０ ∷ １ ∷ ０ ∷ ０ ∷ ０ ∷ １ ∷ １ ∷ ０ ∷ １ ∷ -- s5 0 = s1 , write 1 , right + * ∷ １ ∷ ０ ∷ １ ∷ １ ∷ １ ∷ ０ ∷ １ ∷ １ ∷ ０ ∷ ０ ∷ -- s5 1 = s5 , write 1 , left + [] + + +input-encode : List utmΣ +input-encode = １ ∷ １ ∷ ０ ∷ ０ ∷ ０ ∷ [] + +input+Copyδ : List utmΣ +input+Copyδ = ( $ ∷ ０ ∷ ０ ∷ ０ ∷ ０ ∷ * ∷ [] ) -- start state + ++ Copyδ-encode + ++ ( $ ∷ ^ ∷ input-encode ) + +short-input : List utmΣ +short-input = $ ∷ ０ ∷ ０ ∷ ０ ∷ * ∷ + ０ ∷ ０ ∷ ０ ∷ １ ∷ ０ ∷ １ ∷ １ ∷ * ∷ + ０ ∷ ０ ∷ １ ∷ ０ ∷ １ ∷ １ ∷ １ ∷ * ∷ + ０ ∷ １ ∷ B ∷ １ ∷ ０ ∷ １ ∷ ０ ∷ * ∷ + １ ∷ ０ ∷ ０ ∷ ０ ∷ １ ∷ １ ∷ １ ∷ $ ∷ + ^ ∷ ０ ∷ ０ ∷ １ ∷ １ ∷ [] + +utm-test1 : List utmΣ → utmStates × ( List utmΣ ) × ( List utmΣ ) +utm-test1 inp = Turing.taccept U-TM inp + +{-# TERMINATING #-} +utm-test2 : ℕ → List utmΣ → utmStates × ( List utmΣ ) × ( List utmΣ ) +utm-test2 n inp = loop n (Turing.tstart U-TM) inp [] + where + loop : ℕ → utmStates → ( List utmΣ ) → ( List utmΣ ) → utmStates × ( List utmΣ ) × ( List utmΣ ) + loop zero q L R = ( q , L , R ) + loop (suc n) q L R with move {utmStates} {utmΣ} {０} {utmδ} q L R | q + ... | nq , nL , nR | reads = loop n nq nL nR + ... | nq , nL , nR | _ = loop (suc n) nq nL nR + +t1 = utm-test2 20 short-input + +t : (n : ℕ) → utmStates × ( List utmΣ ) × ( List utmΣ ) +-- t n = utm-test2 n input+Copyδ +t n = utm-test2 n short-input