Mercurial > hg > Papers > 2023 > soto-master
changeset 10:560d341c5cbd
add dpp
author | soto <soto@cr.ie.u-ryukyu.ac.jp> |
---|---|
date | Thu, 26 Jan 2023 21:49:18 +0900 |
parents | 0504b43c3670 |
children | 1a8a9fa534a2 |
files | DPP/ModelChecking.agda |
diffstat | 1 files changed, 83 insertions(+), 22 deletions(-) [+] |
line wrap: on
line diff
--- a/DPP/ModelChecking.agda Mon Jan 23 18:10:19 2023 +0900 +++ b/DPP/ModelChecking.agda Thu Jan 26 21:49:18 2023 +0900 @@ -136,8 +136,22 @@ set-state redu origin (false ∷ ss) f b env envl exit | p ∷ ps | C_eating = set-state redu origin ss (f ++ (p ∷ [])) ps env envl exit -- 変更対象なので変更して奥に進む set-state redu origin (true ∷ ss) f b env envl exit | p ∷ ps | C_thinking = set-state redu origin ss (f ++ (record p{next-code = C_pickup_rfork} ∷ [])) ps env envl exit -- 変更対象なので変更して奥に進む set-state redu origin (false ∷ ss) f b env envl exit | p ∷ ps | C_thinking = set-state redu origin ss (f ++ (p ∷ [])) ps env envl exit -- 変更対象なので変更して奥に進む - set-state redu origin (s ∷ ss) f b env envl exit | p ∷ ps | _ = set-state redu origin state (f ++ (p ∷ [])) ps env envl exit -- 変更対象ではないので奥を対象にする + set-state redu origin st@(s ∷ ss) f b env envl exit | p ∷ ps | _ = set-state redu origin st (f ++ (p ∷ [])) ps env envl exit -- 変更対象ではないので奥を対象にする +-- eatingも探索範囲に含める +brute-force-search-1 : {n : Level} {t : Set n} → Env → (exit : List Bool → t) → t +brute-force-search-1 env exit = make-state-list 1 [] (ph env) env (env ∷ []) exit where + make-state-list : {n : Level} {t : Set n} → ℕ → List Bool → List Phi → Env → (List Env) → (exit : List Bool → t) → t + make-state-list redu state (x ∷ pl) env envl exit with next-code x + ... | C_thinking = make-state-list (redu + redu) (state ++ (false ∷ [])) pl env envl exit + ... | C_eating = make-state-list (redu + redu) (state ++ (false ∷ [])) pl env envl exit + ... | _ = make-state-list redu state pl env envl exit + make-state-list redu state [] env envl exit = bit-force-search redu [] state env envl exit where + bit-force-search : {n : Level} {t : Set n} → ℕ → (f b : List Bool )→ Env → (List Env) → (exit : List Bool → t) → t + bit-force-search zero f l env envl exit = exit [] + bit-force-search (suc redu) f [] env envl exit = exit [] + bit-force-search (suc redu) f (true ∷ bs) env envl exit = bit-force-search (suc redu) (f ++ (false ∷ [])) bs env envl exit + bit-force-search (suc redu) f (false ∷ bs) env envl exit = exit (f ++ (true ∷ bs)) test-search : List Env test-search = init-table 3 (λ e0 → brute-force-search e0 (λ e1 → e1)) @@ -281,6 +295,7 @@ metal : List MetaEnv -- 結局探索して1ステップ実行(インターリーディング)するからMetaEnvのList Envがちょうどよい open MetaEnv2 +-- this one need branch-deadlock-check : {n : Level} {t : Set n} → List MetaEnv → (exit : List MetaEnv → t) → t branch-deadlock-check metaenv exit = search-brute-force-envll-p [] metaenv exit where search-brute-force-envll-p : {n : Level} {t : Set n} → (f b : List (MetaEnv)) → (exit : List (MetaEnv) → t) → t @@ -290,7 +305,8 @@ ... | (env ∷ envs) = brute-force-search env (λ e0 → make-brute-force-envl (length e0) [] metaenv e0 (λ e1 → search-brute-force-envll-p (f ++ e1) bs exit)) where make-brute-force-envl : {n : Level} {t : Set n} → ℕ → List MetaEnv → MetaEnv → (state : List Env) → (exit : List MetaEnv → t) → t make-brute-force-envl len res xs [] exit = exit res - make-brute-force-envl len res xs (x ∷ state) exit = make-brute-force-envl len (res ++ (record xs{DG = (x ∷ DG xs); meta = record (meta xs){num-branch = len}} ∷ [])) xs state exit + make-brute-force-envl len res xs (x ∷ state) exit = brute-force-search env (λ e0 → search-brute-force-envll-p (f ++ ( record metaenv{meta = record (meta metaenv){num-branch = (length e0)} } ∷ [])) bs exit ) + -- make-brute-force-envl len (res ++ (record xs{DG = (x ∷ DG xs); meta = record (meta xs){num-branch = len}} ∷ [])) xs state exit data _===_ {n} {A : Set n} : List A -> List A -> Set n where reflection : {x : List A} -> x === x @@ -305,6 +321,7 @@ testhoge _ _ = {!!} -} +-- this need step-deadlock-check : {n : Level} {t : Set n} → List MetaEnv → (exit : List MetaEnv → t) → t step-deadlock-check metaenvl exit = deadlock-check-p [] metaenvl exit where deadlock-check-p : {n : Level} {t : Set n} → (f b : List (MetaEnv)) → (exit : List (MetaEnv) → t) → t @@ -356,6 +373,45 @@ ... | tri> ¬a ¬b c = judge-deadlock-p (f ++ (metaenv ∷ []) ) bs exit ... | tri≈ ¬a b ¬c = judge-deadlock-p (f ++ (record metaenv{deadlock = true} ∷ []) ) bs exit +waitlist-deadlock-metaenv : {n : Level} {t : Set n} → MetaEnv2 → (exit : MetaEnv2 → t) → t +waitlist-deadlock-metaenv meta2 exit = deadlock-check-p [] (metal meta2) (λ e → exit record meta2{metal = e}) where + deadlock-check-p : {n : Level} {t : Set n} → (f b : List (MetaEnv)) → (exit : List (MetaEnv) → t) → t + deadlock-check-p f [] exit = exit f + deadlock-check-p f b@(metaenv ∷ bs) exit with DG metaenv + ... | [] = deadlock-check-p f bs exit + ... | p0 ∷ envs = step-c p0 (λ e0 → check-wait-process [] (ph p0) e0 ( λ e → deadlock-check-p (f ++ (record metaenv{meta = record (meta metaenv){wait-list = e } } ∷ [])) bs exit) ) where + check-wait-process : {n : Level} {t : Set n} → List ℕ → List Phi → (p1 : Env) → (exit : List ℕ → t) → t + check-wait-process waitl [] p1 exit = exit waitl + check-wait-process waitl (p ∷ ps) p1 exit = hoge11 p (ph p1) (λ e → check-wait-process (waitl ++ e) ps p1 exit) where + hoge11 : {n : Level} {t : Set n} → Phi → List Phi → (exit : List ℕ → t) → t + hoge11 p [] exit = exit [] + hoge11 p (bp ∷ p1s) exit with <-cmp (pid p) (pid bp) + hoge11 p (bp ∷ p1s) exit | tri< a ¬b ¬c = hoge11 p p1s exit + hoge11 p (bp ∷ p1s) exit | tri> ¬a ¬b c = hoge11 p p1s exit + hoge11 p (bp ∷ p1s) exit | tri≈ ¬a b ¬c with (next-code p) + hoge11 p (bp ∷ p1s) exit | tri≈ ¬a b ¬c | next-codea with (next-code bp) + hoge11 p (bp ∷ p1s) exit | tri≈ ¬a b ¬c | C_putdown_rfork | C_putdown_rfork = exit (pid p ∷ []) + hoge11 p (bp ∷ p1s) exit | tri≈ ¬a b ¬c | C_putdown_lfork | C_putdown_lfork = exit (pid p ∷ []) + hoge11 p (bp ∷ p1s) exit | tri≈ ¬a b ¬c | C_thinking | C_thinking = exit (pid p ∷ []) + hoge11 p (bp ∷ p1s) exit | tri≈ ¬a b ¬c | C_pickup_rfork | C_pickup_rfork = exit (pid p ∷ []) + hoge11 p (bp ∷ p1s) exit | tri≈ ¬a b ¬c | C_pickup_lfork | C_pickup_lfork = exit (pid p ∷ []) + hoge11 p (bp ∷ p1s) exit | tri≈ ¬a b ¬c | C_eating | C_eating = exit (pid p ∷ []) + hoge11 p (bp ∷ p1s) exit | tri≈ ¬a b ¬c | _ | _ = exit [] + +check-deadlock-metaenv : {n : Level} {t : Set n} → MetaEnv2 → (exit : MetaEnv2 → t) → t +check-deadlock-metaenv meta2 exit = search-brute-force-envll-p [] (metal meta2) (λ e → exit record meta2{metal = e}) where + search-brute-force-envll-p : {n : Level} {t : Set n} → (f b : List (MetaEnv)) → (exit : List (MetaEnv) → t) → t + search-brute-force-envll-p f [] exit = exit f + search-brute-force-envll-p f b@(metaenv ∷ bs) exit with DG metaenv + ... | [] = search-brute-force-envll-p f bs exit + ... | (env ∷ envs) = brute-force-search env (λ e0 → search-brute-force-envll-p (f ++ ( record metaenv{meta = record (meta metaenv){num-branch = (length e0)} } ∷ [])) bs exit ) + {- + -- brute-force-search env (λ e0 → make-brute-force-envl (length e0) [] metaenv e0 (λ e1 → search-brute-force-envll-p (f ++ e1) bs exit)) where + make-brute-force-envl : {n : Level} {t : Set n} → ℕ → List MetaEnv → MetaEnv → (state : List Env) → (exit : List MetaEnv → t) → t + make-brute-force-envl len res xs [] exit = exit res + make-brute-force-envl len res xs (x ∷ state) exit = make-brute-force-envl len (res ++ (record xs{DG = (x ∷ DG xs); meta = record (meta xs){num-branch = len}} ∷ [])) xs state exit +-} + judge-deadlock-metaenv : {n : Level} {t : Set n} → MetaEnv2 → (exit : MetaEnv2 → t) → t judge-deadlock-metaenv meta2 exit = judge-deadlock-p [] (metal meta2) (λ e → exit record meta2{metal = e} ) where judge-deadlock-p : {n : Level} {t : Set n} → (f b : List (MetaEnv)) → (exit : List (MetaEnv) → t) → t @@ -368,7 +424,7 @@ ... | p ∷ ps with <-cmp (length (wait-list (meta metaenv))) (length (ph p)) ... | tri< a ¬b ¬c = judge-deadlock-p (f ++ (metaenv ∷ []) ) bs exit ... | tri> ¬a ¬b c = judge-deadlock-p (f ++ (metaenv ∷ []) ) bs exit - ... | tri≈ ¬a b ¬c = judge-deadlock-p (f ++ (record metaenv{deadlock = true} ∷ []) ) bs exit + ... | tri≈ ¬a b ¬c = judge-deadlock-p (f ++ (record metaenv{deadlock = false} ∷ []) ) bs exit {- test-env-deadlock : {n : Level} {t : Set n} → (a b : Env)→ (exit : List MetaEnv → t) → t @@ -412,14 +468,14 @@ make-brute-force-envl res (addenv ∷ statel) meta exit = make-brute-force-envl (res ++ ( record meta{DG = addenv ∷ (DG meta); is-done = false; is-step = false} ∷ [])) statel meta exit -step-meta2 : {n : Level} {t : Set n} → MetaEnv2 → (next exit : MetaEnv2 → t) → t -step-meta2 meta2 next1 exit = step-brute-force-p1 [] (metal meta2) (λ envll → next1 record meta2{metal = envll}) (λ e → exit meta2) where +step-meta2 : {n : Level} {t : Set n} → MetaEnv2 → (exit : MetaEnv2 → t) → t +step-meta2 meta2 exit = step-brute-force-p1 [] (metal meta2) (λ envll → exit record meta2{metal = envll}) where step-brute-force-p-p : {n : Level} {t : Set n} → (envl : (List Env)) → (exit : (List Env) → t) → t - step-brute-force-p1 : {n : Level} {t : Set n} → (f b : List (MetaEnv)) → (next exit : List (MetaEnv) → t) → t - step-brute-force-p1 f [] next1 exit = next1 f - step-brute-force-p1 f (metaenv ∷ metaenvl) next1 exit with is-step metaenv - ... | true = step-brute-force-p1 (f ++ (metaenv ∷ [])) metaenvl next1 exit - ... | false = step-brute-force-p-p (DG metaenv) (λ e0 → step-brute-force-p1 (f ++ (record metaenv{DG = e0; is-step = true} ∷ [])) metaenvl next1 exit) + step-brute-force-p1 : {n : Level} {t : Set n} → (f b : List (MetaEnv)) → (exit : List (MetaEnv) → t) → t + step-brute-force-p1 f [] exit = exit f + step-brute-force-p1 f (metaenv ∷ metaenvl) exit with is-step metaenv + ... | true = step-brute-force-p1 (f ++ (metaenv ∷ [])) metaenvl exit + ... | false = step-brute-force-p-p (DG metaenv) (λ e0 → step-brute-force-p1 (f ++ (record metaenv{DG = e0; is-step = true} ∷ [])) metaenvl exit) step-brute-force-p-p [] exit = exit [] step-brute-force-p-p (x ∷ bs) exit = step-c x (λ e0 → exit (e0 ∷ bs)) @@ -457,7 +513,7 @@ ... | env ∷ envs = check-wait-process-p 0 (ph env) env (λ nn → check-wait-process nn pl sss me exit) check-same-env-p : {n : Level} {t : Set n} → (f b : List MetaEnv) → MetaEnv2 → (exit : MetaEnv2 → t) → t check-same-env-p [] [] metae2 exit = exit metae2 - check-same-env-p f@(x ∷ fs) [] metae2 exit = step-meta2 record metae2{metal = f} (λ me2 → branch-search-meta2 me2 (λ me3 → check-same-env me3 exit) exit ) exit + check-same-env-p f@(x ∷ fs) [] metae2 exit = step-meta2 record metae2{metal = f} (λ me2 → branch-search-meta2 me2 (λ me3 → check-same-env me3 exit) exit ) check-same-env-p [] bl@(b ∷ bs) metae2 exit with DG b ... | [] = check-same-env-p [] bs metae2 exit ... | env ∷ envs = check-wait-process 0 (ph env) bl b (λ lme → check-same-env-p ([] ++ lme) bl metae2 exit) @@ -544,19 +600,20 @@ ; next-code = C_thinking } ∷ [] }) + test-env1 : Env test-env1 = (record { - table = 1 ∷ 2 ∷ 0 ∷ [] + table = 1 ∷ 0 ∷ 0 ∷ [] ; ph = record { pid = 1 ; left-hand = false - ; right-hand = false - ; next-code = C_pickup_rfork + ; right-hand = true + ; next-code = C_pickup_lfork } ∷ record { pid = 2 ; left-hand = false ; right-hand = false - ; next-code = C_pickup_rfork + ; next-code = C_thinking } ∷ record { pid = 3 ; left-hand = false @@ -614,7 +671,7 @@ ... | [] = exit origin ... | env1 ∷ envl with DG x ... | [] = loop-metaenv me origin (f ++ (x ∷ [])) metaenvl exit - ... | env2 ∷ history = eq-env origin (ph env1) (ph env2) (λ exit-e → exit record origin{metal = f ++ (record x{is-done = boolor (is-done me) (is-done x); is-step = true } ∷ metaenvl)}) (λ e → loop-metaenv me origin (f ++ (x ∷ [])) metaenvl exit ) + ... | env2 ∷ history = eq-env origin (ph env1) (ph env2) (λ exit-e → exit record origin{metal = f ++ (record x{is-done = boolor (is-done me) (is-done x) } ∷ metaenvl)}) (λ e → loop-metaenv me origin (f ++ (x ∷ [])) metaenvl exit ) eq-env origin [] [] exit loop = exit origin -- true eq-env origin [] (x ∷ pl2) exit loop = loop false @@ -714,7 +771,7 @@ ; left-hand = false ; right-hand = false ; next-code = C_pickup_rfork - } ∷ [] } ∷ []) ∷ [] ; metal = [] }) (λ me0 → check-same-env-test me0 (λ me1 → step-meta2 me1 (λ me2 → branch-search-meta2 me2 ( λ me3 → testhoge me3 me2 (λ me4 → check-same-env-test me4 (λ me5 → me5))) (λ e → e) ) (λ e → e) )) (λ e → e) + } ∷ [] } ∷ []) ∷ [] ; metal = [] }) (λ me0 → check-same-env-test me0 (λ me1 → step-meta2 me1 (λ me2 → branch-search-meta2 me2 ( λ me3 → testhoge me3 me2 (λ me4 → check-same-env-test me4 (λ me5 → me5))) (λ e → e) ) )) (λ e → e) test-dead-lock-meta21 : MetaEnv2 @@ -733,18 +790,22 @@ ; left-hand = false ; right-hand = false ; next-code = C_pickup_rfork - } ∷ [] } ∷ []) ∷ [] ; metal = [] }) (λ me0 → check-same-env-test me0 (λ me1 → step-meta2 me1 (λ me2 → branch-search-meta2 me2 ( λ me3 → testhoge me3 me2 (λ me4 → check-same-env-test me4 (λ me5 → me5))) (λ e → e) ) (λ e → e) )) (λ e → e) + } ∷ [] } ∷ []) ∷ [] ; metal = [] }) (λ me0 → check-same-env-test me0 (λ me1 → step-meta2 me1 (λ me2 → branch-search-meta2 me2 ( λ me3 → testhoge me3 me2 (λ me4 → check-same-env-test me4 (λ me5 → me5))) (λ e → e) ) )) (λ e → e) +check-and-judge-deadlock : {n : Level} {t : Set n} → MetaEnv2 → (exit : MetaEnv2 → t) → t +check-and-judge-deadlock meta2 exit = check-deadlock-metaenv meta2 (λ e0 → waitlist-deadlock-metaenv e0 (λ e → judge-deadlock-metaenv e exit ) ) + test-dead-lock-meta22 : ℕ → MetaEnv2 → MetaEnv2 -test-dead-lock-meta22 zero metaenv2 = metaenv2 -test-dead-lock-meta22 (suc n) metaenv2 = branch-search-meta2 metaenv2 (λ me1 → testhoge me1 metaenv2 (λ me2 → step-meta2 me2 (λ me3 → testhoge me3 me2 (λ me4 → test-dead-lock-meta22 n me4) ) (λ e → e)) ) (λ e → e) +test-dead-lock-meta22 zero metaenv2 = check-and-judge-deadlock metaenv2 (λ e → e) +test-dead-lock-meta22 (suc n) metaenv2 = branch-search-meta2 metaenv2 (λ me2 → step-meta2 me2 (λ me3 → testhoge me3 metaenv2 (λ me4 → test-dead-lock-meta22 n me4) ) ) (λ e5 → e5) {-# TERMINATING #-} test-dead-lock-loop : MetaEnv2 → MetaEnv2 -test-dead-lock-loop metaenv2 = branch-search-meta2 metaenv2 (λ me1 → testhoge me1 metaenv2 (λ me2 → step-meta2 me2 (λ me3 → testhoge me3 me2 (λ me4 → test-dead-lock-loop me4) ) (λ e → e)) ) (λ e → e) +test-dead-lock-loop metaenv2 = branch-search-meta2 metaenv2 (λ me2 → step-meta2 me2 (λ me3 → testhoge me3 metaenv2 (λ me4 → test-dead-lock-loop me4) ) ) (λ e → e) --- test-dead-lock-loop test-metaenv3 +test-dead-lock-loop2 : MetaEnv2 → MetaEnv2 +test-dead-lock-loop2 metaenv2 = branch-search-meta2 metaenv2 (λ me2 → step-meta2 me2 (λ me3 → testhoge me3 metaenv2 (λ me4 → test-dead-lock-loop me4) ) ) (λ e → check-and-judge-deadlock e (λ e1 → e1) ) test-step-c2 : List (List Env) test-step-c2 = init-brute-force (record {