diff options
Diffstat (limited to 'books/workshops/2009/verbeek-schmaltz/verbeek')
27 files changed, 8508 insertions, 0 deletions
diff --git a/books/workshops/2009/verbeek-schmaltz/verbeek/Readme.lsp b/books/workshops/2009/verbeek-schmaltz/verbeek/Readme.lsp new file mode 100644 index 0000000..62f54ed --- /dev/null +++ b/books/workshops/2009/verbeek-schmaltz/verbeek/Readme.lsp @@ -0,0 +1,158 @@ +; Rev.: March 2009 + +((:FILES " +.: +Makefile +Readme.lsp +generic-modules/ +instantiations/ + +./generic-modules: +interfaces-computes.lisp +GeNoC-departure.lisp +GeNoC-interfaces.lisp +GeNoC-misc.lisp +GeNoC-nodeset.lisp +GeNoC-ntkstate.lisp +GeNoC-priority.lisp +GeNoC-routing.lisp +GeNoC-scheduling.lisp +GeNoC-simulation.lisp +GeNoC-synchronization.lisp +GeNoC-types.lisp +GeNoC.lisp +Makefile +own-perm.lisp + +./instantiations: +Makefile +departure/ +genoc/ +interfaces/ +nodeset/ +ntkstate/ +routing/ +scheduling/ +simulation/ +synchronization/ + +./instantiations/departure: +Makefile +simple/ + +./instantiations/departure/simple: +Makefile +simple-R4D.lisp + +./instantiations/genoc: +Makefile +simple-ct-global/ + +./instantiations/genoc/simple-ct-global: +Makefile +sets.lisp +simple.lisp +trlst-equal.lisp + +./instantiations/interfaces: +Makefile +dummy-interfaces/ + +./instantiations/interfaces/dummy-interfaces: +Makefile +interfaces-computes.lisp + +./instantiations/nodeset: +2DMesh-no-ports/ +Makefile + +./instantiations/nodeset/2DMesh-no-ports: +2DMesh.lisp +Makefile + +./instantiations/ntkstate: +Makefile +simple/ + +./instantiations/ntkstate/simple: +Makefile +simple.lisp + +./instantiations/routing: +Makefile +XY/ + +./instantiations/routing/XY: +Makefile +XYRouting.lisp + +./instantiations/scheduling: +Makefile +circuit-switching-global/ + +./instantiations/scheduling/circuit-switching-global: +Makefile +circuit.lisp +intersect.lisp + +./instantiations/simulation: +Makefile +simple/ + +./instantiations/simulation/simple: +Makefile +simple.lisp + +./instantiations/synchronization: +Makefile +circuit-global/ + +./instantiations/synchronization/circuit-global: +Makefile +circuit.lisp +" +) + (:TITLE "Formal Validation of Deadlock Prevention in Networks-on-Chips") + (:AUTHOR/S "Freek Verbeek" "Julien Schmaltz") ; non-empty list of author strings + (:KEYWORDS ; non-empty list of keywords, case-insensitive + "liveness" "networks-on-chips" "formal methods" + ) + (:ABSTRACT +"Complex systems-on-chips (SoCs) are built as the assembly of pre-designed + parameterized components. + The specification and validation of the communication infrastructure + becomes a crucial step in the early phase of any SoC design. + The Generic Network-on-Chip model (GeNoC) has been recently + proposed as a generic specification environment, + restricted to safety properties. + We report on an initial extension of the GeNoC + model with + a generic termination condition and a generic property + showing the prevention of livelock and deadlock. + The latter shows that all messages injected in the + network eventually reach their + destination for all possible values of network + parameters like topology, size of the network, + message length or injection time. + We illustrate our initial results with the validation + of a circuit switching technique. +") + (:PERMISSION ; author/s permission for distribution and copying: +"Deadlock Prevention in Networks-on-Chips +Copyright (C) 2009 F. Verbeek and J. Schmaltz + +This program is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public License +as published by the Free Software Foundation; either version 2 +of the License, or (at your option) any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program; if not, write to the Free Software +Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA +02110-1301, USA.")) + diff --git a/books/workshops/2009/verbeek-schmaltz/verbeek/generic-modules/GeNoC-departure.lisp b/books/workshops/2009/verbeek-schmaltz/verbeek/generic-modules/GeNoC-departure.lisp new file mode 100644 index 0000000..f0c1c3b --- /dev/null +++ b/books/workshops/2009/verbeek-schmaltz/verbeek/generic-modules/GeNoC-departure.lisp @@ -0,0 +1,103 @@ +#|$ACL2s-Preamble$; +;; Amr Helmy +;; Generic departure control of GeNoC + +;;31st october 2007 +;; File: GeNoC-departure.lisp +;; Octobre 2nd, 2007 +(begin-book);$ACL2s-Preamble$|# + +(in-package "ACL2") +(include-book "GeNoC-nodeset") +(include-book "GeNoC-misc") ;; imports also GeNoC-types +(include-book "GeNoC-ntkstate"); + + + +(defspec GenericR4d + ;;this is the module of the network access control + ;;the function has 4 inputs: + ;; 1) the list of messages to be tested + ;; 2) the first accumulator for delayed messages + ;; 3) the second accumulator for departing messages + ;; 4) the condition to use for the test (by default it's time, but + ;; it can be used along something else) + (((readyfordeparture * * * *) => (mv * *))) + + + (local + (defun readyfordeparture (missives delayed departing time) + (declare (ignore delayed departing)) + (let ((mundertest (car missives))) + (mv + ;; TrLst updated + (if (< time (TimeTm mundertest)) + ;;it's finished and we send back the missives + missives + nil) + ;; arrived messages + (if (< time (TimeTm mundertest)) + ;; no one has the clearance to depart. + nil + missives))))) + ;; the first two theorems prove simply that if we pass no messages to + ;; the function it will return an empty list for te two return values + (defthm nil-r4d-nil-mv0 + (not (mv-nth 0 (readyfordeparture nil nil nil time)))) + + (defthm nil-r4d-nil-mv1 + (not (mv-nth 1 (readyfordeparture nil nil nil time)))) + ;; The next theorem prove that the type of the FIRST return value of the + ;; function is a Tmissives + (defthm tmissivesp-ready-4-departure-mv-0 + (implies (tmissivesp m nodeset) + (tmissivesp (mv-nth 0 (readyfordeparture m nil nil time)) + nodeset))) + ;; The next theorem prove that the type of the SECOND return value of the + ;; function is a Tmissives + (defthm tmissivesp-ready-4-departure-mv-1 + (implies (tmissivesp m nodeset) + (tmissivesp (mv-nth 1 (readyfordeparture m nil nil time)) + nodeset))) + + ;; The Identifiers of the first list (delayed) is a subset of the + ;; identifiers of messages passed to the function as input + (defthm subset-ready-for-departure + (implies (tmissivesp m nodeset) + (subsetp (tm-ids (mv-nth 0 (readyfordeparture m nil nil + time))) + (tm-ids m)))) + ;; The Identifiers of the second list (departing) is a subset of the + ;; identifiers of messages passed to the function as input + (defthm subset-ready-for-departure-2 + (implies (tmissivesp m nodeset) + (subsetp (tm-ids (mv-nth 1 (readyfordeparture m nil nil + time))) + (tm-ids m)))) + ;; The elements second list (departing) is a subset of the + ;; messages passed to the function as input + (defthm subset-ready-for-departure-3 + (implies (tmissivesp m nodeset) + (subsetp (mv-nth 1 (readyfordeparture m nil nil time)) + m))) + ;; The elements First list (deLAYED) is a subset of the + ;; messages passed to the function as input + (defthm subset-ready-for-departure-4 + (implies (tmissivesp m nodeset) + (subsetp (mv-nth 0 (readyfordeparture m nil nil time)) + m))) + ;; The IDENTIFIERS of the first output list are distinct of those of + ;; the second (the next two theorem prove the same thing but it is + ;; needed in both forms) + (defthm not-in-1-0-ready-for-dept + (implies (tmissivesp m nodeset) + (not-in (tm-ids (mv-nth 1 (readyfordeparture m nil nil time))) + (tm-ids (mv-nth 0 (readyfordeparture m nil nil time)))))) + + (defthm not-in-1-0-ready-for-dept-reverse + (implies (tmissivesp m nodeset) + (not-in (tm-ids (mv-nth 0 (readyfordeparture m nil nil time))) + (tm-ids (mv-nth 1 (readyfordeparture m nil nil + time)))))) + + );;end of encapsulate diff --git a/books/workshops/2009/verbeek-schmaltz/verbeek/generic-modules/GeNoC-interfaces.lisp b/books/workshops/2009/verbeek-schmaltz/verbeek/generic-modules/GeNoC-interfaces.lisp new file mode 100644 index 0000000..62374b6 --- /dev/null +++ b/books/workshops/2009/verbeek-schmaltz/verbeek/generic-modules/GeNoC-interfaces.lisp @@ -0,0 +1,61 @@ +#|$ACL2s-Preamble$; +;; Julien Schmaltz +;; Interface Module of GeNoC +;; June 17th +;; File: GeNoC-interfaces.lisp +;;Amr helmy +;;31st october 2007 + +(begin-book);$ACL2s-Preamble$|# + + +(in-package "ACL2") +(include-book "make-event/defspec" :dir :system) + +;;------------------------------------------------------------ +;; +;; INTERFACES +;; +;;------------------------------------------------------------ + +(defspec GenericInterfaces + + ( + ;; Any peer has an interface that can send and receive messages + ;; Function p2psend + ;; argument: a message msg and [options] + ;; output: a frame frm + ((p2psend *) => *) + ;; Function p2precv + ;; argument: a frame frm and [options] + ;; output: a message msg + ((p2precv *) => *) + ) + + (local (defun p2psend (msg) msg)) + (local (defun p2precv (frm) frm)) + + (defthm p2p-Correctness + ;; the composition of p2precv and p2psend + ;; is the identity function + (equal (p2precv (p2psend msg)) msg)) + + (defthm p2psend-nil + ;; if msg is nil then p2psend is nil too + (not (p2psend nil))) + + (defthm p2psend-not-nil + ;; if msg is not nil then p2psend is not nil too + (implies msg + (p2psend msg))) + + (defthm p2precv-nil + ;; if frm is nil then p2precv is nil too + (not (p2precv nil))) + + (defthm p2precv-not-nil + ;; if frm is not nil then p2precv is not nil too + (implies frm + (p2precv frm))) + + ) ;; end of interfaces
\ No newline at end of file diff --git a/books/workshops/2009/verbeek-schmaltz/verbeek/generic-modules/GeNoC-misc.lisp b/books/workshops/2009/verbeek-schmaltz/verbeek/generic-modules/GeNoC-misc.lisp new file mode 100644 index 0000000..7140d95 --- /dev/null +++ b/books/workshops/2009/verbeek-schmaltz/verbeek/generic-modules/GeNoC-misc.lisp @@ -0,0 +1,1257 @@ +#|$ACL2s-Preamble$; +;; Amr HELMY +;; Miscelaneous definitions and lemmas + +;;31st october 2007 +;; File: GeNoC-misc.lisp +(begin-book);$ACL2s-Preamble$|# + +(in-package "ACL2") + +(include-book "GeNoC-types") +(include-book "make-event/defspec" :dir :system) +;;|-------------------------------------------------| +;;| | +;;| Not-in | +;;| | +;;|-------------------------------------------------| + +(defun not-in (x y) + (if (or (endp x) (endp y)) + t + (and (not (member (car x) y)) + (not-in (cdr x) y)))) + +(defthm not-in->not-insched + (implies (and (subsetp x y) + (not-in z y)) + (not-in z x))) + +(defthm not-in-2->not-in-append + (implies (and (not-in x z) + (not-in y z)) + (not-in (append x y) z))) + +(defthm not-in-no-duplicatesp-equal-append + ;; if x is not in y and both do not have duplicates then + ;; their append has no duplicate too + (implies (and (no-duplicatesp-equal x) + (not-in x y) + (no-duplicatesp-equal y)) + (no-duplicatesp-equal (append x y)))) + + + +;;|---------------------------------------| +;;| | +;;| Theoremes about Subsetp | +;;| | +;;|---------------------------------------| +;; we prove some useful lemmas about subsetp +(defthm subsetp-expand + (implies (subsetp x y) + (subsetp x (cons z y)))) + +(defthm subsetp-x-x + (subsetp x x)) + +(defthm subsetp-append + (implies (and (subsetp x S) + (subsetp y S)) + (subsetp (append x y) S))) + +(defthm member-equal-subsetp-last + (implies (and (subsetp x NodeSet) + (consp x)) + (member-equal (car (last x)) NodeSet))) + +(defthm subsetp-trans + ;; transitivity of subsetp + (implies (and (subsetp x y) + (subsetp y z)) + (subsetp x z))) + +(defthm subsetp-not-in + ;; if a list y and no element in common with z + ;; then any sublist x of y has no element in z + (implies (and (not-in delayed scheduled) + (subsetp x delayed)) + (not-in x scheduled))) +;;|------------------------------------------| +;;| | +;;| Routing | +;;| | +;;|------------------------------------------| +;; The predicates associated with the routing part are: +;; - ValidRoutep +;; - CorrectRoutesp + +(defun ValidRoutep (r m) + ;; a route r is valid according to a traveling missive m if: + ;; a/ the origin of the r is the current node of m + ;; b/ the destination of r is the destination node of m + ;; c/ r is a subset of NodeSet + ;; d/ a route r has a len >= 2 + (and (equal (car r) (CurTM m)) + (equal (car (last r)) (DestTM m)) + (not (equal (car R) (car (last R)))) ; cur /= dest + (not (equal (OrgTM m) (car (last R)))) ; org /= dest + )) + +(defun CheckRoutes (routes m NodeSet) + ;; checks that a list of routes is correct according to a traveling missive m + (if (endp routes) + t + (let ((r (car routes))) + (and (ValidRoutep r m) + (subsetp r NodeSet) + (member-equal (orgTM m) NodeSet) + (CheckRoutes (cdr routes) m NodeSet))))) + +(defun CorrectRoutesp (TrLst TM NodeSet) + ;; TrLst is a travel list, TM is a list of traveling missives + (if (endp TrLst) + (if (endp TM) + t + nil) + (let* ((tr (car TrLst)) + (msv (car TM)) + (routes (RoutesV tr))) + (and (CheckRoutes routes msv NodeSet) + (equal (IdV tr) (IdTM msv)) + (equal (FrmV tr) (FrmTM msv)) + (equal (OrgV tr) (OrgTM msv)) + (equal (FlitV tr) (FlitTm msv)) + (equal (timeV tr) (TimeTm msv)) + (CorrectRoutesp (cdr TrLst) (cdr TM) NodeSet))))) + + +;; the following three theorems have been moved from the file +;; GeNoC-scheduling + +(defthm checkroutes-member-equal + (implies (and (checkroutes routes m NodeSet) + (member-equal r Routes)) + (validroutep r m))) + +(defthm checkroutes-subsetp-validroute + (implies (and (checkroutes routes m NodeSet) + (consp r) + (subsetp r routes)) + (and (validroutep (car r) m) + (subsetp (car r) NodeSet)))) + +(defthm checkroutes-subsetp + (implies (and (checkroutes routes m NodeSet) + (subsetp routes1 routes)) + (checkroutes routes1 m NodeSet))) + +(defthm checkroutes-orgTM + (implies (and (checkroutes Routes TM NodeSet) + (validfield-route Routes (Orgv TM) nodeset) + (consp routes)) + (member-equal (orgTM TM) NodeSet))) +;;|--------------------------------| +;;| | +;;| Extract-sublst | +;;| | +;;|--------------------------------| + +(defun extract-sublst (Lst Ids) + ;; extracts the element with the Id in Ids + ;; the output is ordered according to Ids + (if (endp Ids) + nil + (append (list (assoc-equal (car Ids) Lst)) + (extract-sublst Lst (cdr Ids))))) + +;;|--------------------------------| +;;| | +;;|General theoremes used later on | +;;| | +;;|--------------------------------| + +(defthm assoc-equal-not-nil + ;; if (assoc-equal e L) is not nil, then + ;; its car is e !! + (implies (assoc-equal e L) + (equal (car (assoc-equal e L)) + e))) + +(defthm cdr-last-equal + (implies (consp (cdr y)) + (equal (not (equal x (car (last y)))) + (not (equal x (car (last (cdr y)))))))) + +;; the next theorems would be better in GeNoC-misc but then we'll +;; loose the reason for their existence +;; to have this lemma used we need to prove some +;; additional properties between len and extract-sublst +;; and len and v-ids (e.g. a is a call to v-ids) + +(defthm len-extract-sublst + (equal (len (extract-sublst l ids)) + (len ids))) + +(defthm len-v-ids + (equal (len (v-ids x)) + (len x))) + +;;|---------------------------------| +;;| | +;;| tomissives | +;;| | +;;|---------------------------------| +(defun ToMissives (TmLst) + ;; convert a Traveling missives List to a Missive List + (if (endp TmLst) + nil + (let* ((tr (car TmLst)) + (id (IdTm tr)) + (org (OrgTm tr)) + (frm (FrmTm Tr)) + (dest (DestTm tr)) + (Flit (FlitTM tr)) + (time (timeTM tr))) + (cons (list Id org frm dest Flit time) + (ToMissives (cdr TmLst)))))) + +;; for the proof of the correctness of GeNOC +;; two important lemmas are needed + +;; the first one rewrites (ToMissives (extract-sublst ..)) +;; to (extract-sublst (tomissives) ... ) +(defthm tomissives-append ;; OK + ;; we first link ToMissives and append + (equal (ToMissives (append A B)) + (append (ToMissives A) (ToMissives B)))) + + +(defthm member-equal-assoc-equal-not-nil + ;; if e is an Id of a travel of L + ;; then (assoc-equal e L) is not nil + (implies (and (member-equal e (V-ids L)) + (TrLstp L NodeSet)) + (assoc-equal e L))) + + +(defthm member-equal-assoc-equal-not-nil-1 + ;; if e is an Id of a travel of L + ;; then (assoc-equal e L) is not nil + (implies (and (member-equal e (tm-ids L)) + (tmissivesp L NodeSet)) + (assoc-equal e L))) + + +(defthm ToMissives-assoc-equal ;; OK + ;; if (assoc-equal e L) is not nil then we can link + ;; assoc-equal and ToTMissives as follows: + ;; (this lemma is needed to prove the next defthm) + (implies (assoc-equal e L) + (equal (ToMissives (list (assoc-equal e L))) + (list (assoc-equal e (ToMissives L)))))) + + +(defthm ToMissives-extract-sublst ;; OK + ;; now we prove our main lemma + (implies (and (subsetp ids (tm-ids L)) + (tmissivesp L NodeSet)) + (equal (ToMissives (extract-sublst L ids)) + (extract-sublst (ToMissives L) ids))) + :otf-flg t + :hints (("GOAL" + :do-not '(eliminate-destructors generalize) + :induct (extract-sublst L ids) + :do-not-induct t + :in-theory (disable ToMissives append)) + ("Subgoal *1/2" + :use ((:instance member-equal-assoc-equal-not-nil-1 + (e (car ids))))))) + + +(defthm member-equal-assoc-equal-not-nil-M-ids ;; OK + ;; if a is in the ids of L then (assoc-equal e L) + ;; is not nil + (implies (and (member-equal e (M-ids L)) + (ValidFields-M L)) + (assoc-equal e L))) + +(defthm member-equal-M-ids-assoc-equal ;; OK + ;; obviously if e in not in the ids of L + ;; then (assoc-equal e L) is nil + (implies (not (member-equal e (M-ids L))) + (not (assoc-equal e L)))) + +(defthm Missivesp-not-assoc-equal ;; OK + ;; if M is Missivesp then nil is not a key in L + (implies (ValidFields-M M) + (not (assoc-equal nil M)))) + +(defthm assoc-equal-extract-sublst-M-lemma ;; OK + ;; if e is not in id1 there is no key equal to e + ;; after filtering according to id1 + (implies (and (not (member-equal e id1)) + (ValidFields-M M)) + (not (assoc-equal e (extract-sublst M id1))))) + +(defthm assoc-equal-extract-sublst-M-1 ;; OK + ;; if e is a key in id1 then e is still a key + ;; after filtering according to id1 + (implies (and (member-equal e id1) + (ValidFields-M M)) + (equal (assoc-equal e (extract-sublst M id1)) + (assoc-equal e M))) + :otf-flg t + :hints (("GOAL" + :do-not-induct t + :induct (extract-sublst M id1)) + ("Subgoal *1/2" + :cases ((member-equal (car id1) (M-ids M)))))) + + +(defthm extract-sublst-cancel-M ;; OK + ;; and now we can prove our second main lemma + (implies (and (subsetp id2 id1) + (ValidFields-m M)) + (equal (extract-sublst (extract-sublst M id1) id2) + (extract-sublst M id2)))) +(defthm equalid-tomissives + (implies (TMissivesp m nodeset) + (equal (M-ids (ToMissives m)) + (Tm-ids m))) + :rule-classes nil) + +(defthm nodup-tmissivesp-tomissives + (implies (TMissivesp m nodeset) + (no-duplicatesp (M-ids (ToMissives m)))) + :hints (("Goal" :use (:instance equalid-tomissives)))) + +(defthm subset-orgs-tomissives + (implies (TMissivesp m nodeset) + (subsetp (m-orgs (tomissives m))nodeset))) + +(defthm subset-dests-tomissives + (implies (TMissivesp m nodeset) + (subsetp (m-dests (tomissives m)) nodeset))) + +(defthm fwd-missivesp + ;; as missivesp is disabled we prove this rule to add + ;; the content of missivesp as hypotheses + (implies (missivesp M NodeSet) + (and (Validfields-M M) + (subsetp (M-orgs M) NodeSet) + (subsetp (M-dests M) NodeSet) + (True-listp M) + (No-duplicatesp-equal (M-ids M)))) + :rule-classes :forward-chaining) + +(defthm valid-fieldstm-implies-validfieldm + (implies (tmissivesp m nodeset) + (validfields-m (ToMissives m)))) + +(defthm tomissives-truelistp + (implies (Tmissivesp M nodeset) + (true-listp (tomissives m)))) + +(defthm to-missives-missivesp + (implies (TMissivesp m nodeset) + (Missivesp (ToMissives m) NodeSet)) + :hints(("Goal" + :use ((:instance nodup-tmissivesp-tomissives) + (:instance subset-dests-tomissives) + (:instance subset-orgs-tomissives) + (:instance valid-fieldstm-implies-validfieldm) + (:instance tomissives-truelistp)) + :in-theory (disable tomissives-truelistp tmissivesp + subset-dests-tomissives + subset-orgs-tomissives + valid-fieldstm-implies-validfieldm)))) + + +(defthm tomissives-len-equal + (equal (len (tomissives x)) + (len x))) + +(defthm m-ids-append-invert + ;; append out of the mids + (implies (and (missivesp a nodeset) + (missivesp b nodeset)) + (equal (m-ids (append a b)) + (append (m-ids a) (m-ids b))))) + +(defthm missivesp-append-noduplicates + ;; appending the ids of two missivesp that has no ids in common + ;; result in a non duplicates list + (implies (and (missivesp a nodeset) + (missivesp b nodeset) + (not-in (m-ids a) (m-ids b))) + (no-duplicatesp (append (m-ids a) (m-ids b)) )) + :hints (("Goal" :do-not '(eliminate-destructors generalize)))) + +(defthm missivesp-append-missivesp + ;;appending 2 missivesp with no intersections in the ids result in a + ;;missivesp + (implies (and (missivesp a nodeset) + (missivesp b nodeset) + (not-in (m-ids a) (m-ids b))) + (missivesp (append a b) nodeset)) + :hints (("Goal" :do-not '(eliminate-destructors generalize) ) + ("Subgoal *1/2" :use ((:instance m-ids-append-invert ) + (:instance missivesp-append-noduplicates))))) + + +(defthm extract-sublst-subsetp-M-ids ;; OK + ;; filtering a list l according to a subset ids of its identifiers + ;; produces a list the ident. of which are ids + (implies (and (subsetp ids (M-ids l)) + (true-listp ids) + (missivesp l nodeset)) + (equal (M-ids (extract-sublst l ids)) + ids))) + +(defthm valid-missive-assoc-equal ;; OK + ;; a list of a member of a valid list of missives + ;; is a valid list of missives + (implies (and (Missivesp M NodeSet) + (member-equal e (M-ids M))) + (Missivesp (list (assoc-equal e M)) NodeSet))) + +(defthm Missivesp-cons ;; OK + ;; lemma used in the next defthm + ;; if we cons a valid missive to a filtered valid list + ;; of missives, we obtain a valid list of missives if the + ;; the id of the consed missive is not in the filter + (implies (and (Missivesp (extract-sublst M ids) nodeset) + (Missivesp (list (assoc-equal e M)) nodeset) + (not (member-equal e ids)) + (subsetp ids (M-ids M))) + (Missivesp (cons (assoc-equal e M) (extract-sublst M ids)) + nodeset))) + +(defthm missivespx-m-ids-car-x-equal-idm-carx ;;OK + ;;equivalence between idm of car of a list + ;;and the car of the m-ids of the same list + (implies (missivesp x nodeset) + (equal (Idm (car x))(car(m-ids x)))) + :rule-classes nil) + +(defthm memberequal-implies-id-member-missives ;OK + ;; member of a list then the id of the element is a member of the + ;; ids of the list + (implies (member-equal x l) + (member-equal (idm x) (m-ids l)))) + +(defthm member-cdr-id-not-eq-car-missives ;OK + ;;if x is a member in the cdr y then the id of car of y is not equal + ;;to x's id + (implies (and (no-duplicatesp-equal (m-ids y)) + (member-equal x (cdr y))) + (not (equal (idm x) (idm (car y))))) + :hints (("Goal" + :use (:instance memberequal-implies-id-member-missives + (l (cdr y)))))) + +(defthm member-cdr-id-not-eq-carbis-missives ;;OK + ;;same as the previous theorem but with the car instead of the idm + ;; to use in some cases instead of removing the idm + ;; this theorem might be removed + (implies (and (no-duplicatesp (m-ids y)) + (member-equal x (cdr y))) + (not (equal (idm x) (car (car y))))) + :hints (("Goal" :use (:instance member-cdr-id-not-eq-car-missives + )))) + +(defthm assoc-eq-member-cdr-eq-extraction-missives ;;ok + (implies (and (missivesp y nodeset) + (member x (cdr y))) + (equal (assoc-equal (idm x) y) + (assoc-equal (idm x) (cdr y)) )) + :hints (("Goal" + :use (:instance member-cdr-id-not-eq-carbis-missives) + :in-theory (disable Idm m-ids validfields-m) + :do-not '(eliminate-destructors generalize)))) + + +(defthm id-not-eq-car-member-cdr-missives + ;; the inverse of one of the previous lemmas, if the id of x isn't + ;; equal to the id of the first element of y and x is a member of y + ;; then x is a member of cdr y + (implies (and (not (equal (idm x) (caar y))) + (member-equal x y)) + (member-equal x (cdr y)))) + +(defthm missivesy-missives-cdry + ;; missivesp y then missivesp cdr y + (implies (missivesp y nodeset) + (missivesp (cdr y) nodeset))) + +(defthm member-assoc-eq-equalx-missives + ;;using th eid of x which is a member of a missivep y to extract an + ;;element from y will be equal to x + (implies (and (missivesp y nodeset) + (consp x) + (member-equal x y)) + (equal (assoc-equal (idm x) y) x)) + :hints (("Goal" + :use (:instance missivesy-missives-cdry) + :in-theory (disable Idm t-ids validfields-m) + :do-not '(eliminate-destructors generalize)))) + + +(defthm m-ids-cdr-equal-cdr-m-ids + (implies (missivesp x nodeset ) + (equal (cdr(m-ids x)) + (m-ids (cdr x)) )) + :rule-classes nil) + +(defthm missivesp-equal-subsetp ;;OK + (implies (and (missivesp x nodeset) + (missivesp y nodeset) + (subsetp x y)) + (equal (extract-sublst y (m-ids x)) x)) + :rule-classes nil + :hints (("Goal" + :use ((:instance member-assoc-eq-equalx-missives (x (car x))) + (:instance missivespx-m-ids-car-x-equal-idm-carx) + (:instance m-ids-cdr-equal-cdr-m-ids)) + :do-not '(eliminate-destructors generalize) + :in-theory (disable member-assoc-eq-equalx-missives)) + ("Subgoal *1/2" + :use ((:instance member-assoc-eq-equalx-missives (x (car x))) + (:instance m-ids-cdr-equal-cdr-m-ids))))) + + +(defthm missivesp-equal-extract-two-levels ;;ok + (implies (and (missivesp x nodeset) + (subsetp x m) + (subsetp y x) + (missivesp m nodeset) + (missivesp y nodeset)) + (equal (extract-sublst m (m-ids y)) + (extract-sublst x (m-ids y)))) + :rule-classes nil + :hints (("Goal" :use ((:instance missivesp-equal-subsetp (y M) (x y)) + (:instance missivesp-equal-subsetp (y X) (x y))) + :in-theory (disable Validfields-m) + :do-not '(eliminate-destructors)))) + + + +(defthm missivesp-sublst-subsetp ;;ok + (implies (and (missivesp x nodeset) + (missivesp y nodeset) + (missivesp z nodeset)) + (equal + (append (extract-sublst x (m-ids y)) (extract-sublst x (m-ids z))) + (extract-sublst x (append (m-ids y) (m-ids z))))) + :rule-classes nil) + + + +(defthm tmissives-subset-extract-tomissives-equal + (implies (and (tmissivesp x nodeset) + (subsetp ids (tm-ids x))) + (equal (extract-sublst (tomissives x) ids) + (tomissives (extract-sublst x ids)))) + :rule-classes nil + :hints (("Goal" + :use (:instance ToMissives-extract-sublst (l x) ) + :do-not '(eliminate-destructors generalize)))) + + +(defthm subsetpx-y-equal-extract-missives + (implies (and (subsetp x y) + (subsetp ids (m-ids x)) + (subsetp (m-ids x) (m-ids y)) + (missivesp x nodeset) + (missivesp y nodeset)) + (equal (extract-sublst (extract-sublst Y (m-ids x)) ids) + (extract-sublst x ids))) + :rule-classes nil + :hints (("Goal" + :use ((:instance missivesp-equal-subsetp))))) + +(defthm subsetpx-y-equal-extract-final-missives + ;; if x subsetp of y and ids is subsetp of x's ids then the + ;; extraction from x is equal to the extraction of y + (implies (and (subsetp x y) + (subsetp ids (m-ids x)) + (subsetp (m-ids x) (m-ids y)) + (missivesp x nodeset) + (missivesp y nodeset)) + (equal (extract-sublst x ids) + (extract-sublst y ids))) + :rule-classes nil + :hints (("Goal" + :use ((:instance subsetpx-y-equal-extract-missives ) + (:instance extract-sublst-cancel-M + (M y) + (Id2 ids) + (Id1 (m-ids x))))))) + + + +;;|------------------------------| +;;| | +;;| toTmissives | +;;| | +;;|------------------------------| + +(defun ToTMissives (TrLst) + ;; convert a Travel List to a Traveling Missive List + (if (endp TrLst) + nil + (let* ((tr (car TrLst)) + (frm (FrmV tr)) + (org (OrgV tr)) + (routes (RoutesV tr)) + (id (IdV tr)) + (Flit (FlitV tr)) + (Time (TimeV tr))) + (cons (list id org (caar routes) frm (car (last (car routes))) Flit time) + (ToTMissives (cdr TrLst)))))) + +(defthm correctroutesp-=>-toTmissives ;; OK + (implies (and (CorrectRoutesp TrLst TM NodeSet) + (TMissivesp TM NodeSet) + (TrLstp TrLst NodeSet)) + (equal (ToTMissives TrLst) TM))) + +(defthm TM-ids-ToMissives-V-ids ;; OK + (equal (TM-ids (ToTMissives x)) (V-ids x))) + +(defthm CorrectRoutesp-member-equal ;; OK + (implies (and (correctRoutesp TrLst (ToTMissives TrLst) NodeSet) + (TrLstp TrLst NodeSet) + (member-equal e (v-ids TrLst))) + (checkroutes (RoutesV (assoc-equal e TrLst)) + (assoc-equal e (ToTMissives TrLst)) + NodeSet))) + + + + + +;; for the proof of the correctness of GeNOC +;; two important lemmas are needed + +;; the first one rewrites (ToMissives (extract-sublst ..)) +;; to (extract-sublst (tomissives) ... ) +(defthm ToTMissives-append ;; OK + ;; we first link ToTMissives and append + (equal (ToTMissives (append A B)) + (append (ToTMissives A) (ToTMissives B)))) + +(defthm ToTMissives-assoc-equal ;; OK + ;; if (assoc-equal e L) is not nil then we can link + ;; assoc-equal and ToTMissives as follows: + ;; (this lemma is needed to prove the next defthm) + (implies (assoc-equal e L) + (equal (ToTMissives (list (assoc-equal e L))) + (list (assoc-equal e (ToTMissives L)))))) + +(defthm ToTMissives-extract-sublst ;; OK + ;; now we prove our main lemma + (implies (and (subsetp ids (V-ids L)) + (TrLstp L NodeSet)) + (equal (ToTMissives (extract-sublst L ids)) + (extract-sublst (ToTMissives L) ids))) + :otf-flg t + :hints (("GOAL" + :do-not '(eliminate-destructors generalize) + :induct (extract-sublst L ids) + :do-not-induct t + :in-theory (disable ToTMissives append)) + ("Subgoal *1/2" + :use ((:instance member-equal-assoc-equal-not-nil + (e (car ids))))))) + + +;; the second lemma we need, allow us to cancel +;; one successive call of extract-sublst +(defthm member-equal-assoc-equal-not-nil-TM-ids ;; OK + ;; if a is in the ids of L then (assoc-equal e L) + ;; is not nil + (implies (and (member-equal e (TM-ids L)) + (ValidFields-TM L)) + (assoc-equal e L))) + +(defthm member-equal-TM-ids-assoc-equal ;; OK + ;; obviously if e in not in the ids of L + ;; then (assoc-equal e L) is nil + (implies (not (member-equal e (TM-ids L))) + (not (assoc-equal e L)))) + +(defthm TMissivesp-not-assoc-equal ;; OK + ;; if M is Missivesp then nil is not a key in L + (implies (ValidFields-TM M) + (not (assoc-equal nil M)))) + + +(defthm assoc-equal-extract-sublst-TM-lemma ;; OK + ;; if e is not in id1 there is no key equal to e + ;; after filtering according to id1 + (implies (and (not (member-equal e id1)) + (ValidFields-TM M)) + (not (assoc-equal e (extract-sublst M id1))))) + +(defthm assoc-equal-extract-sublst-M ;; OK + ;; if e is a key in id1 then e is still a key + ;; after filtering according to id1 + (implies (and (member-equal e id1) + (ValidFields-TM M)) + (equal (assoc-equal e (extract-sublst M id1)) + (assoc-equal e M))) + :otf-flg t + :hints (("GOAL" + :do-not-induct t + :induct (extract-sublst M id1)) + ("Subgoal *1/2" + :cases ((member-equal (car id1) (TM-ids M)))))) + +(defthm extract-sublst-cancel-TM ;; OK + ;; and now we can prove our second main lemma + (implies (and (subsetp id2 id1) + (ValidFields-TM M)) + (equal (extract-sublst (extract-sublst M id1) id2) + (extract-sublst M id2)))) + + + + + +;;;-------------------------------------- +;; Finally, we prove that the correctness of the routes +;; is preserved by extract-sublst +(defthm extract-sublst-identity + (implies (TrLstp TrLst nodeset) + (equal (extract-sublst TrLst (V-ids TrLst)) + TrLst))) + +(defthm assoc-equal-ToTMissives-not-nil ;; OK + ;; if e is in the ids of L then there is a key equal to + ;; e in (ToTMissives L) + (implies (and (TrLstp L nodeset) + (member-equal e (V-ids L))) + (assoc-equal e (ToTMissives L)))) + +(defthm ToTMissives-CorrectRoutesp-Extract-sublst ;; OK + ;; we prove the current lemma + (implies (and (subsetp ids (V-ids TrLst)) + (TrLstp TrLst nodeset) + (CorrectRoutesp TrLst (ToTMissives TrLst) NodeSet)) + (CorrectRoutesp (extract-sublst TrLst ids) + (ToTMissives (extract-sublst TrLst ids)) + NodeSet))) + + +;; Finally, we prove that converting a list of travels +;; to a list of Tmissives gives something that is recoginized +;; by TMissivesp +(defthm TMissivesp-ToMissives + (implies (and (correctroutesp TrLst (ToTMissives TrLst) NodeSet) + (TrLstp TrLst nodeset)) + (TMissivesp (ToTMissives TrLst) NodeSet))) + +;; next theorem is a generalisation of the previous one + +(defthm TMissivesp-ToMissives-bis + (implies (trlstp trlst nodeset) + (TMissivesp (ToTMissives TrLst) NodeSet))) + +(defthm fwd-tmissivesp + ;; as Tmissivesp is disabled we prove this rule to add + ;; the content of Tmissivesp as hypotheses + (implies (Tmissivesp M NodeSet) + (and (Validfields-TM M) + (subsetp (TM-orgs M) NodeSet) + (subsetp (TM-curs M) NodeSet) + (subsetp (TM-dests M) NodeSet) + (True-listp M) + (No-duplicatesp-equal (TM-ids M)))) + :rule-classes :forward-chaining) + + +(defthm tm-ids-append-invert + (implies (and (tmissivesp a nodeset) + (tmissivesp b nodeset)) + (equal (tm-ids (append a b)) + (append (tm-ids a) (tm-ids b))))) + +(defthm tmissivesp-append-noduplicates + (implies (and (tmissivesp a nodeset) + (tmissivesp b nodeset) + (not-in (tm-ids a) (tm-ids b))) + (no-duplicatesp (append (tm-ids a) (tm-ids b)) )) + :hints (("Goal" :do-not '(eliminate-destructors generalize)))) + +(defthm tmissivesp-append-tmissivesp + (implies (and (tmissivesp a nodeset) + (tmissivesp b nodeset) + (not-in (tm-ids a) (tm-ids b))) + (tmissivesp (append a b) nodeset)) + :hints (("Goal" :do-not '(eliminate-destructors generalize) ) + ("Subgoal *1/2" :use ((:instance tm-ids-append-invert ) + (:instance tmissivesp-append-noduplicates))))) + + +(defthm extract-sublst-subsetp-TM-ids ;; OK + ;; filtering a list l according to a subset ids of its identifiers + ;; produces a list the ident. of which are ids + (implies (and (subsetp ids (TM-ids l)) + (true-listp ids) + (Tmissivesp l nodeset)) + (equal (TM-ids (extract-sublst l ids)) + ids))) +(defthm valid-tmissive-assoc-equal ;; OK + ;; a list of a member of a valid list of missives + ;; is a valid list of missives + (implies (and (TMissivesp M NodeSet) + (member-equal e (TM-ids M))) + (TMissivesp (list (assoc-equal e M)) NodeSet))) + +(defthm TMissivesp-cons ;; OK + ;; lemma used in the next defthm + ;; if we cons a valid missive to a filtered valid list + ;; of missives, we obtain a valid list of missives if the + ;; the id of the consed missive is not in the filter + (implies (and (TMissivesp (extract-sublst M ids) nodeset) + (TMissivesp (list (assoc-equal e M)) nodeset) + (not (member-equal e ids)) + (subsetp ids (TM-ids M))) + (TMissivesp (cons (assoc-equal e M) (extract-sublst M ids)) + nodeset))) + +(defthm tmissivesp-extract + ;;extracting a part of Tmissives list will give a Tmissivesp + (implies (and (tmissivesp M nodeset) + (subsetp ids (tm-ids M)) + (no-duplicatesp-equal ids)) + (tmissivesp (extract-sublst M ids) nodeset))) + +(defthm tmissivespx-tm-ids-car-x-equal-idtm-carx + ;; getting the car out of the IDTM + (implies (tmissivesp x nodeset) + (equal (IDTM (car x))(car(tm-ids x)))) + :rule-classes nil) + +(defthm memberequal-implies-id-member ;OK + ;; the IDs of a member of a list are part of the ids of this list + (implies (member-equal x l) + (member-equal (idtm x) (tm-ids l)))) + + +(defthm member-cdr-id-not-eq-car + (implies (and (no-duplicatesp-equal (tm-ids y)) + (member-equal x (cdr y))) + (not (equal (idtm x) (idtm (car y))))) + :hints (("Goal" + :use (:instance memberequal-implies-id-member + (l (cdr y)))))) + +;; the following theorem is to be removed as soon as i find the place +;; where it's used and then deactivate the functino IDTM + + +(defthm member-cdr-id-not-eq-carbis + ;; if x is a member of cdr y and no duplicates y then idtm of x is + ;; not equal to idtm of car y + (implies (and (no-duplicatesp (tm-ids y)) + (member-equal x (cdr y))) + (not (equal (idtm x) (car (car y))))) + :hints (("Goal" + :use (:instance member-cdr-id-not-eq-car)))) + +(defthm assoc-eq-member-cdr-eq-extraction ;;ok + ;; x member of cdr y the idtm is only in the ids of cdr y + (implies (and (tmissivesp y nodeset) + (member x (cdr y))) + (equal (assoc-equal (idtm x) y) + (assoc-equal (idtm x) (cdr y)) )) + :hints (("Goal" + :use (:instance member-cdr-id-not-eq-carbis) + :in-theory (disable Idtm tm-ids validfields-tm) + :do-not '(eliminate-destructors generalize)))) + +(defthm id-not-eq-car-member-cdr + (implies (and (not (equal (idtm x) (caar y))) + (member-equal x y)) + (member-equal x (cdr y)))) + +(defthm tmissivesy-tmissives-cdry + (implies (tmissivesp y nodeset) + (tmissivesp (cdr y) nodeset))) + +(defthm member-assoc-eq-equalx + (implies (and (tmissivesp y nodeset) + (consp x) + (member-equal x y)) + (equal (assoc-equal (idtm x) y) x)) + :hints (("Goal" + :use (:instance tmissivesy-tmissives-cdry ) + :in-theory (disable Idtm tm-ids validfields-tm) + :do-not '(eliminate-destructors generalize)))) + + +(defthm tm-ids-cdr-equal-cdr-tm-ids + ;; getting the cdr out of the tm-ids + (implies (tmissivesp x nodeset ) + (equal (cdr(tm-ids x))(tm-ids (cdr x)) )) + :rule-classes nil) + + + +(defthm tmissivesp-equal-subsetp ;;ok + ;;extracting from a tmissivesp a list based upon the ids of subsetp + ;;qill be equal to the subset list + (implies (and (tmissivesp x nodeset) + (tmissivesp y nodeset) + (subsetp x y)) + (equal (extract-sublst y (tm-ids x)) x)) + :rule-classes nil + :hints (("Goal" + :use ((:instance member-assoc-eq-equalx (x (car x))) + (:instance tmissivespx-tm-ids-car-x-equal-idtm-carx) + (:instance tm-ids-cdr-equal-cdr-tm-ids)) + :do-not '(eliminate-destructors generalize) + :in-theory (disable member-assoc-eq-equalx )) + ("Subgoal *1/2" + :use ((:instance member-assoc-eq-equalx (x (car x))) + (:instance tm-ids-cdr-equal-cdr-tm-ids))))) + +(defthm tmissivesp-equal-extract-two-levels ;;ok + (implies (and (tmissivesp x nodeset) + (subsetp x m) + (subsetp y x) + (tmissivesp m nodeset) + (tmissivesp y nodeset)) + (equal (extract-sublst m (tm-ids y)) + (extract-sublst x (tm-ids y)))) + :rule-classes nil + :hints (("Goal" + :use ((:instance tmissivesp-equal-subsetp (y M) (x y)) + (:instance tmissivesp-equal-subsetp (y X) (x y))) + :in-theory (disable Validfields-Tm) + :do-not '(eliminate-destructors)))) + + + +(defthm tmissivesp-sublst-subsetp ;;ok + ;; getting the append into the extract sublst + (implies (and (tmissivesp x nodeset) + (tmissivesp y nodeset) + (tmissivesp z nodeset)) + (equal + (append (extract-sublst x (tm-ids y)) + (extract-sublst x (tm-ids z))) + (extract-sublst x (append (tm-ids y) (tm-ids z))))) + :rule-classes nil) + +(defthm subsetpx-y-equal-extract + (implies (and (subsetp x y) + (subsetp ids (tm-ids x)) + (subsetp (Tm-ids x) (tm-ids y)) + (tmissivesp x nodeset) + (tmissivesp y nodeset)) + (equal (extract-sublst (extract-sublst Y (tm-ids x)) ids) + (extract-sublst x ids))) + :rule-classes nil + :hints (("Goal" + :use ((:instance tmissivesp-equal-subsetp) )))) + + +(defthm subsetpx-y-equal-extract-final + (implies (and (subsetp x y) + (subsetp ids (tm-ids x)) + (subsetp (Tm-ids x) (tm-ids y)) + (tmissivesp x nodeset) + (tmissivesp y nodeset)) + (equal (extract-sublst x ids) + (extract-sublst y ids))) + :rule-classes nil + :hints (("Goal" + :use ((:instance subsetpx-y-equal-extract ) + (:instance extract-sublst-cancel-tM + (M y) + (Id2 ids) + (Id1 (tm-ids x))))))) + +(defthm tm-frms-to-v-frms ;; ok + ;; this rule is only used to rewrite the theorem arrived-v-frms-m-frms to + ;;s/d-travel-v-frms. + (equal (tm-frms (totmissives x)) + (v-frms x)) + :rule-classes nil) +;;|------------------------------| +;;| | +;;| Travels | +;;| | +;;|------------------------------| + +(defthm valid-trlstp-assoc-equal + (implies (and (TrLstp L nodeset) + (member-equal e (V-ids L))) + (TrLstp (list (assoc-equal e L))nodeset))) + +(defthm TrLstp-cons + ;; lemma used in the next defthm + ;; if we cons a valid travel to a filtered valid list + ;; of travel, we obtain a valid list of travel if the + ;; consed travel has an id less than the first of the filter + ;; and this id is not in the filter + (implies (and (trlstp (extract-sublst L ids)nodeset) + (trlstp (list (assoc-equal e L))nodeset) + (not (member-equal e ids)) + (subsetp ids (V-ids L))) + (trlstp (cons (assoc-equal e L) + (extract-sublst L ids))nodeset))) + +(defthm trlstp-extract-sublst + (implies (and (TrLstp TrLst nodeset) + (subsetp ids (v-ids TrLst)) + (no-duplicatesp ids) + (true-listp ids)) + (trlstp (extract-sublst TrLst ids) nodeset))) + +(defthm extract-sublst-subsetp-v-ids + (implies (and (subsetp ids (V-ids l)) + (true-listp ids) + (TrLstp l nodeset)) + (equal (v-ids (extract-sublst l ids)) + ids)) + :hints (("GOAL" + :in-theory (disable TrLstp)))) + +(defthm fwd-trlstp + ;; because we disable trlstp, this rule adds its content + ;; as hypotheses + (implies (TrLstp TrLst nodeset) + (and (validfields-trlst trlst nodeset) + (true-listp trlst) + (no-duplicatesp-equal (v-ids trlst)))) + :rule-classes :forward-chaining) + +(defthm validfields-append + ;; lemma for validfields-trlst-genoc_nt + (implies (and (validfields-trlst l1 nodeset) + (validfields-trlst l2 nodeset)) + (validfields-trlst (append l1 l2) nodeset))) + +(defthm trlstpx-v-ids-car-x-equal-idv-carx ;;OK + ;;equivalence between idm of car of a list and the car of the m-ids + ;;of the same list + (implies (trlstp x nodeset) + (equal (Idv (car x))(car(v-ids x)))) + :rule-classes nil) + +(defthm memberequal-implies-id-member-trlst ;OK + ;; member of a list then the id of the element is a member of the + ;; ids of the list + (implies (member-equal x l) + (member-equal (idv x) (v-ids l)))) + + +(defthm member-cdr-id-not-eq-car-trlst ;OK + ;;if x is a member in the cdr y then the id of car of y is not equal + ;;to x's id + (implies (and (no-duplicatesp-equal (v-ids y)) + (member-equal x (cdr y))) + (not (equal (idv x) (idv (car y))))) + + :hints (("Goal" + :use + (:instance memberequal-implies-id-member-trlst (l (cdr y)))))) + +(defthm member-cdr-id-not-eq-carbis-trlst ;OK + ;;same as the previous theorem but with the car instead of the idm + ;; to use in some cases instead of removing the idm + ;; this theorem might be removed + (implies (and (no-duplicatesp (v-ids y)) + (member-equal x (cdr y))) + (not (equal (idv x) (car (car y))))) + :hints (("Goal" :use (:instance member-cdr-id-not-eq-car-trlst )))) + +(defthm assoc-eq-member-cdr-eq-extraction-trlst ;;ok + (implies (and (trlstp y nodeset) + (member x (cdr y))) + (equal (assoc-equal (idv x) y) + (assoc-equal (idv x) (cdr y)) )) + :hints (("Goal" :use (:instance member-cdr-id-not-eq-carbis-trlst) + :in-theory (disable Idv v-ids validfields-trlst) + :do-not '(eliminate-destructors generalize)))) + + +(defthm id-not-eq-car-member-cdr-trlst + ;; the inverse of one of the previous lemmas, if the id of x isn't + ;; equal to the id of the first element of y and x is a member of y + ;; then x is a member of cdr y + (implies (and (not (equal (idv x) (caar y))) + (member-equal x y)) + (member-equal x (cdr y)))) + +(defthm trlsty-trlst-cdry + ;; missivesp y then missivesp cdr y + (implies (trlstp y nodeset) + (trlstp (cdr y) nodeset))) + +(defthm member-assoc-eq-equalx-trlst + ;;using the id of x which is a member of a missivep y to extract an + ;;element from y will be equal to x + (implies (and (trlstp y nodeset) + (consp x) + (member-equal x y)) + (equal (assoc-equal (idv x) y) x)) + :hints (("Goal" :use (:instance trlsty-trlst-cdry ) + :in-theory (disable Idv v-ids validfields-trlst) + :do-not '(eliminate-destructors generalize)))) + + +(defthm v-ids-cdr-equal-cdr-v-ids + (implies (trlstp x nodeset ) + (equal (cdr(v-ids x))(v-ids (cdr x)) )) + :rule-classes nil) + +(defthm trlstp-equal-subsetp ;;OK + (implies (and (trlstp x nodeset) + (trlstp y nodeset) + (subsetp x y)) + (equal (extract-sublst y (v-ids x)) x)) + :rule-classes nil + :hints (("Goal" + :use ((:instance member-assoc-eq-equalx-trlst (x (car x))) + (:instance trlstpx-v-ids-car-x-equal-idv-carx) + (:instance v-ids-cdr-equal-cdr-v-ids)) + :do-not '(eliminate-destructors generalize) + :in-theory (disable member-assoc-eq-equalx-trlst)) + ("Subgoal *1/2" + :use ((:instance member-assoc-eq-equalx-trlst (x (car x))) + (:instance v-ids-cdr-equal-cdr-v-ids))))) + + +(defthm trlstp-equal-extract-two-levels ;;ok + (implies (and (trlstp x nodeset) + (subsetp x m) + (subsetp y x) + (trlstp m nodeset) + (trlstp y nodeset)) + (equal (extract-sublst m (v-ids y)) + (extract-sublst x (v-ids y)))) + :rule-classes nil + :hints (("Goal" + :use ((:instance trlstp-equal-subsetp (y M) (x y)) + (:instance trlstp-equal-subsetp (y X) (x y))) + :in-theory (disable Validfields-trlst) + :do-not '(eliminate-destructors)))) + + +(defthm member-equal-assoc-equal-not-nil-v-ids ;; OK + ;; if a is in the ids of L then (assoc-equal e L) + ;; is not nil + (implies (and (member-equal e (v-ids L)) + (ValidFields-Trlst l nodeset)) + (assoc-equal e L))) + + + +(defthm member-equal-v-ids-assoc-equal ;; OK + ;; obviously if e in not in the ids of L + ;; then (assoc-equal e L) is nil + (implies (not (member-equal e (v-ids L))) + (not (assoc-equal e L)))) + +(defthm Trlstp-not-assoc-equal ;; OK + ;; if M is Missivesp then nil is not a key in L + (implies (ValidFields-Trlst M nodeset) + (not (assoc-equal nil M)))) + +(defthm assoc-equal-extract-sublst-Trlst-lemma ;; OK + ;; if e is not in id1 there is no key equal to e + ;; after filtering according to id1 + (implies (and (not (member-equal e id1)) + (ValidFields-Trlst M nodeset)) + (not (assoc-equal e (extract-sublst M id1))))) + + + +(defthm assoc-equal-extract-sublst-trlst ;; OK + ;; if e is a key in id1 then e is still a key + ;; after filtering according to id1 + (implies (and (member-equal e id1) + (ValidFields-Trlst M nodeset)) + (equal (assoc-equal e (extract-sublst M id1)) + (assoc-equal e M))) + :otf-flg t + :hints (("GOAL" + :do-not-induct t + :induct (extract-sublst M id1)) + ("Subgoal *1/2" + + :cases ((member-equal (car id1) (v-ids M)))) + ("Subgoal *1/2.1" + :use (:instance Trlstp-not-assoc-equal)))) + +(defthm extract-sublst-cancel-Trlst ;; OK + ;; and now we can prove our second main lemma + (implies (and (subsetp id2 id1) + (ValidFields-Trlst M nodeset)) + (equal (extract-sublst (extract-sublst M id1) id2) + (extract-sublst M id2)))) + + +;;|------------------------------| +;;| | +;;| rev | +;;|------------------------------| +(defun rev (x) + (if (endp x) + nil + (append (rev (cdr x)) (list (car x))))) + +(defthm subset-rev + (implies (and (trlstp x nodeset) + (trlstp y nodeset) + (subsetp x y)) + (subsetp x (rev y)))) + +(defthm subset-rev-1st + (implies (and (trlstp x nodeset) + (trlstp y nodeset) + (subsetp x y)) + (subsetp (rev x) y))) + +(defthm subsetpvids-rev + (implies (and (trlstp x nodeset) + (trlstp y nodeset) + (subsetp (v-ids x) (v-ids y))) + (subsetp (rev (v-ids x)) (v-ids y)))) + +;;|------------------------------| +;;| | +;;| Transactionsp | +;;| | +;;|------------------------------| + +(defthm fwd-chaining-transactionsp + (implies (transactionsp trs nodeset) + (and (validfields-t trs) + (true-listp trs) + (subsetp (t-orgs trs) nodeset) + (subsetp (t-dests trs) nodeset) + (no-duplicatesp-equal (t-ids trs)))) + :rule-classes :forward-chaining) + +(defthm fwd-chaining-transactionsp-bis + (implies (transactionsp trs nodeset) + (and (validfields-t trs) + (true-listp trs) + (subsetp (t-orgs trs) nodeset) + (subsetp (t-dests trs) nodeset))) + :rule-classes :forward-chaining)#|ACL2s-ToDo-Line|# + + +;; valid ntkstate +(defthm validstate-entry-implies-coord-and-buffer + (implies (and (validstate-entryp x) + (consp x)) + (and (validcoord (car x)) + (validbuffer (cadr x)))))
\ No newline at end of file diff --git a/books/workshops/2009/verbeek-schmaltz/verbeek/generic-modules/GeNoC-nodeset.lisp b/books/workshops/2009/verbeek-schmaltz/verbeek/generic-modules/GeNoC-nodeset.lisp new file mode 100644 index 0000000..4b68cf6 --- /dev/null +++ b/books/workshops/2009/verbeek-schmaltz/verbeek/generic-modules/GeNoC-nodeset.lisp @@ -0,0 +1,61 @@ +#|$ACL2s-Preamble$; +;; Julien Schmaltz +;; Generic Set of Nodes +;; June 17th 2005 +;; File: GeNoC-nodeset.lisp +;; modified byAmr HELMY + +;;31st october 2007 +(begin-book);$ACL2s-Preamble$|# + +;;use of Defspec +;; this allows us to removethe (defthm t) at the end of each instance file +(in-package "ACL2") +(include-book "make-event/defspec" :dir :system) + +(defspec GenericNodeSet + ;; abstract set of nodes + ;; the set is generated by the following function + ;; its argument is the parameters + (((NodesetGenerator *) => *) + ;; the following predicate recognizes valid parameters + ((ValidParamsp *) => *) + ;; the following predicate recognizes a valid node + ((Nodep *) => *) + ((NodeSetp *) => *)) + + ;; local witnesses + (local (defun ValidParamsp (x) + (declare (ignore x)) t)) + + (local (defun NodesetGenerator (x) + (if (zp x) nil + (cons x (NodesetGenerator (1- x)))))) + + (local (defun Nodep (n) + (natp n))) + + (local (defun NodeSetp (l) + (if (endp l) t + (and (Nodep (car l)) + (NodeSetp (cdr l)))))) + + (defthm nodeset-generates-valid-nodes + ;; the result of the nodesetgenerator is a valid list of nodes + (implies (ValidParamsp params) + (NodeSetp (NodesetGenerator params)))) + + ;; we add a generic lemma + (defthm subsets-are-valid + ;; this lemma is used to prove that routes are made of valid nodes + (implies (and (NodeSetp x) + (subsetp y x)) + (NodeSetp y))) + + + (defthm true-listp-nodesetgenerator + (implies (Validparamsp x) + (true-listp (NodesetGenerator x)))) + + ) ;; end GenericNodeSet + diff --git a/books/workshops/2009/verbeek-schmaltz/verbeek/generic-modules/GeNoC-ntkstate.lisp b/books/workshops/2009/verbeek-schmaltz/verbeek/generic-modules/GeNoC-ntkstate.lisp new file mode 100644 index 0000000..dd205a6 --- /dev/null +++ b/books/workshops/2009/verbeek-schmaltz/verbeek/generic-modules/GeNoC-ntkstate.lisp @@ -0,0 +1,158 @@ +#|$ACL2s-Preamble$; +;;Amr helmy +;;31st october 2007 +;; Rev. 31 Jan. 2008 by JS +(begin-book);$ACL2s-Preamble$|# + +(in-package "ACL2") + +(include-book "GeNoC-nodeset") +(include-book "GeNoC-misc") +(include-book "GeNoC-types") +(include-book "make-event/defspec" :dir :system)#|ACL2s-ToDo-Line|# + + +(defspec GenericNodesetbuffers + (((StateGenerator * *) => *) + ;; Function StateGenerator generates + ;; a state from two parameters + ;; the first one is the parameter used to + ;; generate the list of the nodes of the network + ((ValidstateParamsp * *) => *) + ;; recognizer for valid parameters + ((loadbuffers * * *)=> *) + ;; update the state + ;; inputs = node_id (in NodeSet), a message and a state + ;; return a new state + ;;((unloadbuffers * *) => *)) + ((readbuffers * *) => *) + ;; read the state + ;; input = node_id (in NodeSet) and a state + ;; returns the state entry corresponding to node_id + ((generate-initial-ntkstate * *) => *)) + ;; put the list of transaction on the network + ;; + ;; A network state is a list of node representing the state of the network + ;; a state entry has the form : + ;; ( (coor (...)) + ;; (Buffers ...) + ;; ) + ;; + ;;example : + ;; ( ((coor (2 3)) (buffers 4 3)) + ;; ((coor (3 2)) (buffers 5 3)) + ;; ((coor (5 4)) (buffers 2 3))) + ;; + ;; n: is the number of buffers on this specific coordinate + ;; m: is the actual numbr of free buffers on this specific coordinate + ;; example : ((coord (2 3)) (buffers 4 2)) + ;; this means that the node coordinate is (2 3) and that + ;;it has 4 buffers of which only 2 are free + ;; The functions in the defspec serve for the following + + + ;;---------------------- Witness Functions ----------- + ;; Local functions for the next witness function + ;; this function does not have to be instantiated + (local + (defun stategeneratorlocal (nodeset y) + (if (endp nodeset) + nil + (append (list (list (list 'Coor (car nodeset)) (list 'Buffers y))) + (StateGeneratorlocal (cdr nodeset) y))))) + + + (local + ;;a function taking a natural as input and generating a list of nodes + (defun StateGenerator (x y) + (let ((nodes (nodesetgenerator x))) + (stategeneratorlocal nodes y)))) + + ;; A function that verifies the the input parameters of the state + ;; genration function + + (local + (defun ValidStateParamsp (x y) + (declare (ignore y)) + (validparamsp x))) + + (local + (defun loadbuffers (coordinates msgid ntkstate) + (declare (ignore coordinates msgid)) + ;; this function takes as input the coordinates of a node and + ;; loads a buffer + ;; in case there's still free buffers + ntkstate)) + + (local + (defun readbuffers (node_id ntkstate) + (declare (ignore node_id)) + (car ntkstate))) + + (local + (defun generate-initial-ntkstate (talst ntkstate) + (declare (ignore talst)) + ntkstate)) + +;;---------------------- End Witness Functions ----------- + + (local + (defthm validstate-stategenerator + (validstate (stategeneratorlocal listx params2)))) + + ;; theoreme to prove the correctness + (defthm nodeset-generates-valid-resources + (implies (ValidStateParamsp params params2) + (ValidState (StateGenerator params params2)))) + + ;; The funciton loadbuffers returns a validstate + (defthm validstate-loadbuffers-statep + (implies (validstate ntkstate) + (validstate (loadbuffers coordinates msgid ntkstate)))) + + (local + (defthm valid-entry-car-stategeneratorlocal + (validstate-entryp (car (stategeneratorlocal p1 p2))))) + + (defthm Readbuffers-valid-entryp + ;; reading a valid state for a valid node + ;; returns a valid state entry + (let ((ntkstate (StateGenerator p1 p2)) + (NodeSet (NodeSetGenerator p1))) + (implies (and (ValidStateParamsp p1 p2) + (member-equal node_id NodeSet)) + (ValidState-entryp (Readbuffers node_id ntkstate))))) + + + ;; this proof obligation is important to do the link between the + ;; nodesetgenerator and the stategenerator + ;; it states that The Validity of the stategenerator inputs must + ;; imply the validity of + ;; the input of the nodeset + (defthm Validstateparamsp-implies-validparamsp + (implies (ValidStateparamsp param1 param2) + (Validparamsp param1))) + + ;;this is an intermediate theorem used for the next one + (local + (defthm getcoordinates-stategenerator-local + (implies (true-listp listx) + (equal (getcoordinates (stategeneratorlocal listx params2)) + listx)))) + + ;; We prove the equality between the nodeset and the coordinates in + ;; the stategenerator + + (defthm nodesetp-coordinates + (implies (ValidStateparamsp param1 param2) + (equal (getcoordinates (StateGenerator param1 param2)) + (nodesetgenerator param1))) + :hints (("Goal" + :do-not '(generalize)))) + + (defthm subsets-are-valid-resources + ;; this lemma is used to prove that routes are made of valid state nodes + (implies (and (ValidState nodelist) + (subsetp y nodelist)) + (ValidState y))) + )
\ No newline at end of file diff --git a/books/workshops/2009/verbeek-schmaltz/verbeek/generic-modules/GeNoC-priority.lisp b/books/workshops/2009/verbeek-schmaltz/verbeek/generic-modules/GeNoC-priority.lisp new file mode 100644 index 0000000..eacb396 --- /dev/null +++ b/books/workshops/2009/verbeek-schmaltz/verbeek/generic-modules/GeNoC-priority.lisp @@ -0,0 +1,77 @@ +#|$ACL2s-Preamble$; +;;Amr HELMY +;; 19th march 2008 +;;GeNoC-priority.lisp +;; this file contains the proof obligations of the generic priority function +;; the priority is implemented as a sorting function that classes the +;; travels in order of their priority folowing an order + + + +(begin-book);$ACL2s-Preamble$|# + +(in-package "ACL2") + +(include-book "own-perm") +(include-book "GeNoC-types") +(include-book "GeNoC-misc") + +(defspec GenericPriority + (((prioritysorting * *)=> * )) + + + (local + (defun prioritysorting (trlst order) + (declare (ignore order)) + trlst)) + + ;; the output of the function is just a permutation of the input + (defthm isperm-prioritysorting + (implies (trlstp trlst nodeset) + (is-perm (v-ids (prioritysorting trlst order)) + (v-ids trlst)))) + + ;;the type of the output is a trlstp + (defthm trlstp-prioritysorting + (implies (trlstp trlst nodeset) + (trlstp (prioritysorting trlst order) nodeset))) + + ;; the output is a subsetp of the input (to be sure no travels are created) + (defthm subsetp-prioritysorting-trlst + (implies (trlstp trlst nodeset) + (subsetp (prioritysorting trlst order) trlst))) + + ;; the identifiers of the output is a subset of those of the input + ;; remove and put a general relation between is-perm and subsetp + (defthm subsetp-v-ids-priority-trlst + (implies (trlstp trlst nodeset) + (subsetp (v-ids (prioritysorting trlst order)) + (v-ids trlst)))) + ;; the result of the function is a true-listp + ;;remove next theorem + (defthm true-listp-priority-sorting + (implies (trlstp trlst nodeset) + (true-listp (prioritysorting trlst order)))) + + ;; the origins of the output is a subset of those of the input + (defthm subsetp-orgs-prioritysort + (implies (trlstp trlst nodeset) + (subsetp (v-orgs (prioritysorting trlst order)) + (v-orgs trlst)))) + + ;; the frames of the output is a subset of those of the input + (defthm subsetp-frms-prioritysort + (implies (trlstp trlst nodeset) + (subsetp (v-frms (prioritysorting trlst order)) + (v-frms trlst)))) + + ;; the destinations of the output after transformation to missives + ;; is a subset of those of the input after the same transformation + (defthm subsetp-prioritysort_mdests + (implies (trlstp trlst nodeset) + (subsetp (m-dests (tomissives + (totmissives (prioritysorting trlst order)) )) + (m-dests (tomissives(totmissives trlst)))))) + + + );;END OF encapsulation diff --git a/books/workshops/2009/verbeek-schmaltz/verbeek/generic-modules/GeNoC-routing.lisp b/books/workshops/2009/verbeek-schmaltz/verbeek/generic-modules/GeNoC-routing.lisp new file mode 100644 index 0000000..de56088 --- /dev/null +++ b/books/workshops/2009/verbeek-schmaltz/verbeek/generic-modules/GeNoC-routing.lisp @@ -0,0 +1,138 @@ +#|$ACL2s-Preamble$; +;; Julien Schmaltz +;; Generic Routing Module of GeNoC +;; June 20th 2005 +;; File: GeNoC-routing.lisp +;; Edited by Amr HELMY and Laurence PIERRE +;; november 27th 2007 +(begin-book);$ACL2s-Preamble$|# + +(in-package "ACL2") + +;; we import the books for the set of nodes and about the data-types +(include-book "GeNoC-nodeset") +(include-book "GeNoC-misc") ;; import also GeNoC-types + +(defspec GenericRouting + ;; Routing computes the route of each message within the network + ;; It takes as arguments: TM and NodeSet + ;; It outputs a list of travel TrLst = (... (Id org frm Route) ...) + ;; Constraints: + ;; 1/ If the input is a list of valid missives, the output must be + ;; a list of valid travels (Ids are still unique) + ;; 2/ Every route of every travel must be correct + ;; 3/ Frms of the output must be equal to the frms of the input + ;; 4/ Orgs of the output must be equal to the orgs of the input + + (((Routing * *) => *)) + + ;; local witnesses + (local (defun route (TM) + ;; this would be the routing in a bus + (if (endp TM) + nil + (let* ((msv (car TM)) + (Id (IdTM msv)) + (frm (FrmTM msv)) + (origin (OrgTM msv)) + (current (CurTM msv)) + (destination (DestTM msv)) + (flit (FlitTM msv)) + (time (TimeTM msv))) + (cons (list Id origin frm (list (list current + destination)) + Flit time) + + (route (cdr TM))))))) + + (local (defun routing (M NodeSet) + (declare (ignore NodeSet)) + (route M))) + + ;; 1/ If the input is a list of valid missives, the output must be + ;; a list of valid travels (Ids are still unique) + + ;; local lemmas + (local (defthm route-ids + ;; ids of the output TrLst are equal to the ids of + ;; the initial missives + (equal (V-Ids (route M)) (TM-Ids M)))) + + (local (defthm route-orgs ;; EN LOCAL ????? + ;; orgs of the output TrLst are equal to the orgs of + ;; the initial missives + (equal (V-orgs (route M)) (TM-orgs M)))) + + (local (defthm TrLstp-route + ;; typing of the result of the function route + (implies (TMissivesp M nodeset) + (TrLstp (route M) nodeset)))) + + (defthm TrLstp-routing + ;; 1st constraint + ;; the travel list is recognized by TrLst + ;; Params is a free variable + (let ((NodeSet (NodeSetGenerator Params))) + (implies (and (TMissivesp M NodeSet) + (ValidParamsp Params)) + (TrLstp (routing M NodeSet) NodeSet)))) + + ;; 2/ Routes must satisfy the predicate CorrectRoutesp + (local + (defthm correctroutesp-route + ;; the routes preoduced by route are correct + (implies (TMissivesp M NodeSet) + (CorrectRoutesp (route M) M NodeSet)))) + + (defthm Routing-CorrectRoutesp + ;; 2nd constraint + ;; The routes produced by routing are correct + (let ((NodeSet (NodeSetGenerator Params))) + (implies (and (TMissivesp M NodeSet) + (ValidParamsp Params)) + (CorrectRoutesp (Routing M NodeSet) M NodeSet)))) + + ;; some additional constraints + (defthm true-listp-routing + (true-listp (routing M NodeSet)) + :rule-classes :type-prescription) + + (defthm routing-nil + ;; the routing has to return nil if the list of missives is nil + (not (routing nil NodeSet))) + ) ;; end of routing + + + +(defthm tomissives-routing + ;; the result of the routing converted into Tmisssives is equal to + ;; the original input + ;;list of Tmissives passed to the function as input + (let ((NodeSet (NodeSetGenerator Params))) + (implies (and (TMissivesp M NodeSet) + (ValidParamsp Params)) + (equal (ToTMissives (routing M NodeSet)) M))) + :hints (("GOAL" + :use (:instance correctroutesp-=>-toTmissives + (TrLst (Routing M (NodeSetGenerator Params))) + (TM M) + (NodeSet (NodeSetGenerator Params))) + :in-theory (disable TMissivesp + correctroutesp-=>-toTmissives) + :do-not-induct t))) + +(defthm ids-routing + ;; the ids of the output of routing are equal to the ids + ;; of the initial list of missives + (let ((NodeSet (NodeSetGenerator Params))) + (implies (and (TMissivesp M NodeSet) + (ValidParamsp Params)) + (equal (V-ids (routing M NodeSet)) + (TM-ids M)))) + :hints (("GOAL" + :use ((:instance ToMissives-Routing)) + :in-theory (disable ToMissives-Routing)))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + diff --git a/books/workshops/2009/verbeek-schmaltz/verbeek/generic-modules/GeNoC-scheduling.lisp b/books/workshops/2009/verbeek-schmaltz/verbeek/generic-modules/GeNoC-scheduling.lisp new file mode 100644 index 0000000..e985ff2 --- /dev/null +++ b/books/workshops/2009/verbeek-schmaltz/verbeek/generic-modules/GeNoC-scheduling.lisp @@ -0,0 +1,307 @@ +#|$ACL2s-Preamble$; +; Julien Schmaltz +;; Generic Scheduling Module of GeNoC +;; Feb 16th 2005 +;; File: GeNoC-scheduling.lisp +;; Amr HELMY Revised and modified January 24th 2008 +;;edited by Amr HELMY, Laurence Pierre august 22nd of august 2007 + +;;Amr helmy +;;31st october 2007 + +(begin-book);$ACL2s-Preamble$|# + +(in-package "ACL2") +(include-book "GeNoC-nodeset") +(include-book "GeNoC-misc") ;; imports also GeNoC-types +(include-book "GeNoC-ntkstate")#|ACL2s-ToDo-Line|# +; +;; Inputs: TrLst = ( ... (Id org frm route) ...), measure, NodeSet, and +;; the current network state +;; outputs: TrLst updated, arrived missives, new state of the network, +;; measure updated + + +(defspec GenericScheduling + ;; Function Scheduling represents the scheduling policy of the + ;; network. + ;; arguments: TrLst measure P + ;; outputs: newTrLst Arrived newP newMeasure + (((scheduling * * * *) => (mv * * * *)) + ((get_next_priority *)=> *) + ((scheduling-assumptions * * * *) => *) + ((legal-measure * * * * *) => *) + ((initial-measure * * * *) => *)) + + (local (defun get_next_priority (port) + port)) + (local (defun scheduling-assumptions (TrLst NodeSet ntkstate order) + (declare (ignore TrLst NodeSet ntkstate order)) + nil)) + (local (defun legal-measure (measure trlst nodeset ntkstate order) + (declare (ignore measure trlst nodeset ntkstate order)) + nil)) + (local (defun initial-measure (trlst nodeset ntkstate order) + (declare (ignore trlst nodeset ntkstate order)) + nil)) + (local (defun scheduling (TrLst NodeSet ntkstate order) + ;; local witness + (mv + ;; TrLst updated + (if (not (scheduling-assumptions TrLst NodeSet ntkstate order)) + (totmissives TrLst) + nil) + ;; arrived messages + ;(if (is-base-measure measure) + nil + ; TrLst) + ;; measure is nil + nil + ;; ntkstate preserved + ntkstate) + )) + + ;; Proof obligations (also named constraints) + ;; ----------------------------------------- + (defthm scheduled-nil-nil + ;; the result of the scheduling function in the case of empty + ;; input list is equal to nil + (equal (car (scheduling nil nodeset ntkstate order)) nil)) + + ;; 1/ Types of newTrLst, Arrived and P (state) + ;; --------------------------------- + ;; The type of newTrLst is a valid traveling missives list + + (defthm tmissivesp-newTrlst + (implies (trlstp TrLst nodeset) + (tmissivesp (mv-nth 0 (scheduling TrLst NodeSet ntkstate order)) + NodeSet))) + + ;; so is the list of Arrived + (defthm trlstp-Arrived ;; OK + (implies (trlstp TrLst nodeset) + (trlstp (mv-nth 1 (scheduling TrLst NodeSet ntkstate order)) + nodeset))) + + ;; the state list P is a ValidState + (defthm Valid-state-ntkstate + (implies (validstate ntkstate) + (validstate (mv-nth 3 (scheduling TrLst NodeSet ntkstate order))))) + + + ;; 2/ the measure provided to GeNoC must be decreasing. + ;; ------------------------------------------------------ + ;; scheduling-assumptions must be a boolean + (defthm booleanp-assumptions + (booleanp (scheduling-assumptions TrLst NodeSet ntkstate order)) + :rule-classes :type-prescription) + + ;; legal-measure nust be a boolean + (defthm booleanp-legal-measure + (booleanp (legal-measure measure trlst nodeset ntkstate order)) + :rule-classes :type-prescription) + + ;; the measure must decrease on each call of scheduling + (defthm measure-decreases + (implies (and (legal-measure measure trlst nodeset ntkstate order) + (scheduling-assumptions trlst NodeSet ntkstate order)) + (O< (acl2-count (mv-nth 2 (scheduling TrLst NodeSet ntkstate order))) + (acl2-count measure)))) + + + ;; 3/ Correctness of the arrived missives + ;; ------------------------------------------------------------------ + ;; For any arrived missive arr, there exists a unique travel + ;; tr in the initial TrLst, such that IdV(arr) = IdV(tr) + ;; and FrmV(arr) = FrmV(tr) and RoutesV(arr) is a + ;; sublist of RoutesV(tr). + ;; In ACL2, the uniqueness of the ids is given by the predicate + ;; TrLstp. + ;; ------------------------------------------------------------------- + + ;; First, let us define this correctness + (defun s/d-travel-correctness (arr-TrLst TrLst/arr-ids) + (if (endp arr-TrLst) + (if (endp TrLst/arr-ids) + t + nil) + (let* ((arr-tr (car arr-TrLst)) + (tr (car TrLst/arr-ids))) + (and (equal (FrmV arr-tr) (FrmV tr)) + (equal (IdV arr-tr) (IdV tr)) + (equal (OrgV arr-tr) (OrgV tr)) + (equal (FlitV arr-tr) (FlitV tr)) + (equal (timeV arr-tr) (TimeV tr)) + (subsetp (RoutesV arr-tr) (RoutesV tr)) + (s/d-travel-correctness (cdr arr-TrLst) + (cdr TrLst/arr-ids)))))) + + + (defthm s/d-travel-correctness-unitary + (implies (trlstp x nodeset) + (s/d-travel-correctness x x))) + + (defthm arrived-travels-correctness + (mv-let (newTrLst Arrived newMeasure newstate ) + (scheduling TrLst NodeSet ntkstate order) + (declare (ignore newTrLst newMeasure newstate )) + (implies (TrLstp TrLst nodeset) + (s/d-travel-correctness + Arrived + (extract-sublst TrLst (V-ids Arrived))))) + :hints (("Goal" :in-theory (disable trlstp)))) + + (defthm subsetp-arrived-newTrLst-ids + ;; this should be provable from the two lemmas above + ;; but it will always be trivial to prove, and it is + ;; useful in subsequent proofs. + (mv-let (newTrLst Arrived newMeasure newstate ) + (scheduling TrLst NodeSet ntkstate order) + (declare (ignore newMeasure newstate )) + (implies (TrLstp TrLst nodeset) + (and (subsetp (v-ids Arrived) (v-ids Trlst)) + (subsetp (Tm-ids newTrLst) (v-ids TrLst)))))) + + + ;; 4. Correctness of the newTrLst travels + ;; ------------------------------------- + ;; the correctness of the newTrLst travels differs from + ;; the correctness of the Arrived travels because, + ;; for the Arrived travels we will generally keep only + ;; one route, but for the newTrLst travels we will not modify + ;; the travels and keep all the routes. In fact, by + ;; converting a travel back to a missive we will remove the + ;; routes. + ;; --------------------------------------------------------- + + ;; the list newTrLst is equal to filtering the initial + ;; TrLst according to the Ids of newTrLst + + + + (defthm newTrLst-travel-correctness ;; OK + ;; the correctness of newtrlst is the equivalence of the transformation + ;;of the newtrlst into missives, and the transformation of the + ;;initial trlst (input to the scheduling function) + ;;into tmissives and then to missives + ;; this rule will cause an infinite number of rewrites that's why + ;; it's in rule-classes nil, we have to create an instance to use + ;; it + (mv-let (newTrLst Arrived newMeasure newstate ) + (scheduling TrLst NodeSet ntkstate order) + (declare (ignore Arrived newMeasure newstate)) + (implies (TrLstp TrLst nodeset) + (equal (tomissives newTrLst) + (extract-sublst (tomissives(totmissives + TrLst)) + (Tm-ids newTrLst))))) + + :rule-classes nil) + + ;; 6/ if scheduling assumptions are not met, measure is nil + (defthm mv-nth-2-scheduling-on-zero-measure ;; OK + ;; if the scheduling measure is 0 + ;; the new measure is equal to the initial one + (implies (and (not (scheduling-assumptions TrLst NodeSet ntkstate order)) + (TrLstp trlst nodeset)) + (equal (mv-nth 2 (scheduling TrLst NodeSet ntkstate order)) ;; new measure + nil))) + + (defthm mv-nth-0-scheduling-on-zero-measure ;; OK + ;; if the scheduling measure is 0 + ;; the set of newTrLst s is equal to the initial TrLst + (implies (not (scheduling-assumptions TrLst NodeSet ntkstate order)) + (equal + (mv-nth 0 (scheduling TrLst NodeSet ntkstate order)) + (totmissives TrLst)))) + + ;; 7/ The intersection of the ids of the Arrived travels and those + ;; of the newTrLst travels is empty + ;; ----------------------------------------------------------------- + + (defthm not-in-newTrLst-Arrived ;; OK + (mv-let (newTrLst Arrived newmeasure newstate ) + (scheduling TrLst NodeSet ntkstate order) + (declare (ignore newmeasure newstate )) + (implies (TrLstp TrLst nodeset) + (not-in (Tm-ids newTrLst) (v-ids Arrived))))) + + ;; some constraints required because we do not have a definition + ;; for scheduling + (defthm consp-scheduling ;; OK + ;; for the mv-nth + (consp (scheduling TrLst NodeSet ntkstate order)) + :rule-classes :type-prescription) + + (defthm true-listp-car-scheduling ;; OK + (implies (true-listp TrLst) + (true-listp (mv-nth 0 (scheduling TrLst NodeSet + ntkstate order )))) + + :rule-classes :type-prescription) + + (defthm true-listp-mv-nth-1-sched-1 ;; OK + (implies (true-listp TrLst) + (true-listp (mv-nth 1 (scheduling TrLst NodeSet + ntkstate order)))) + + :rule-classes :type-prescription) + + (defthm true-listp-mv-nth-1-sched-2 ;; OK + (implies (TrLstp TrLst nodeset) + (true-listp (mv-nth 1 (scheduling TrLst NodeSet + ntkstate order)))) + + :rule-classes :type-prescription) + + ) ;; end of scheduling + + +(defthm correctroutesp-s/d-travel-correctness ;; OK + ;; correctroutesp between trlst/ids and it's transformation into + ;; tmissves, and the s/d-travel-correctness, between trlst/ids and + ;; trlst1 + ;; implies the correctroutesp between trlst1 and trlst/ids + (implies (and (CorrectRoutesp TrLst/ids (ToTMissives TrLst/ids) NodeSet) + (s/d-travel-correctness TrLst1 TrLst/ids)) + (CorrectRoutesp TrLst1 + (ToTMissives TrLst/ids) NodeSet))) + + +(defthm scheduling-preserves-route-correctness ;; OK + ;; we prove that sheduling preserve the correctness of the routes + ;; after the transformation + (mv-let (newTrLst Arrived newmeasure newstate ) + (scheduling TrLst NodeSet ntkstate order) + (declare (ignore newTrLst newstate newmeasure )) + (implies (and (CorrectRoutesp TrLst (ToTMissives TrLst) NodeSet) + (TrLstp TrLst nodeset)) + (CorrectRoutesp Arrived + (ToTMissives + (extract-sublst + TrLst + (V-ids Arrived))) + NodeSet))) + :otf-flg t + :hints (("GOAL" + :do-not '(eliminate-destructors generalize) + :do-not-induct t + :in-theory + (disable mv-nth ;; to have my rules used + ToTMissives-extract-sublst TrLstp)))) + + +(defthm TMissivesp-mv-nth-0-scheduling ;; OK + (let ((NodeSet (NodeSetGenerator Params))) + (implies (and (CorrectRoutesp TrLst (ToTMissives TrLst) NodeSet) + (ValidParamsp Params) + (TrLstp TrLst nodeset)) + (TMissivesp (mv-nth 0 (scheduling TrLst NodeSet + ntkstate order)) + NodeSet))) + + :hints (("Goal" + :use + (:instance tmissivesp-newTrlst + (nodeset (NodeSetGenerator Params)))))) + diff --git a/books/workshops/2009/verbeek-schmaltz/verbeek/generic-modules/GeNoC-simulation.lisp b/books/workshops/2009/verbeek-schmaltz/verbeek/generic-modules/GeNoC-simulation.lisp new file mode 100644 index 0000000..64b891d --- /dev/null +++ b/books/workshops/2009/verbeek-schmaltz/verbeek/generic-modules/GeNoC-simulation.lisp @@ -0,0 +1,34 @@ +#|$ACL2s-Preamble$; +;;Amr helmy +;;4th august 2008 +;; GeNoC-simulation.lisp +;; this file contains the definition of the generic simulation extraction +;; functions, they only are used to extract the simulation and have no formal value. +(begin-book );$ACL2s-Preamble$|# + + +(in-package "ACL2") +(include-book "make-event/defspec" :dir :system) + + + + +(defspec Genericsimulationextraction +(((extract-simulation *) => *)) +;;the next two function should be modified given the form of the network state +(local (defun treat-state-entry (coor contents) + (if (endp contents) + nil + (cons (list coor (caar contents) (cadar contents)) + (treat-state-entry coor (cdr contents)))))) + +(local +(defun extract-simulation (ntkstate) + (if (endp ntkstate) + nil + (append (treat-state-entry (cadaar ntkstate) (cdadr + (car + ntkstate))) + (extract-simulation (cdr ntkstate)))))) + +)#|ACL2s-ToDo-Line|# diff --git a/books/workshops/2009/verbeek-schmaltz/verbeek/generic-modules/GeNoC-synchronization.lisp b/books/workshops/2009/verbeek-schmaltz/verbeek/generic-modules/GeNoC-synchronization.lisp new file mode 100644 index 0000000..852e874 --- /dev/null +++ b/books/workshops/2009/verbeek-schmaltz/verbeek/generic-modules/GeNoC-synchronization.lisp @@ -0,0 +1,125 @@ +#|$ACL2s-Preamble$; +;; Amr HELMY +;; 27th, March 2008 +;; GeNoC-synchronisation.lisp +;; this file contains the generic representation of the local +;; synchronisation policies +;; between the nodes, ex: 2 steps and 4 steps handshaking algorithm +;;still a Draft +(begin-book);$ACL2s-Preamble$|# + +(in-package "ACL2") + +(include-book "GeNoC-misc")#|ACL2s-ToDo-Line|# + + +(defspec genericsynchronisation + (;;req_tans is the equivalent of requesting a transmission in a + ;;synchronisation protocol, it takes whatever action is suuposed to + ;;be taken to initialise a communication + ((req_trans *) => *) + ;;next function is the function that checks if we can put the + ;;acknowledge to 1 or not really + ((process_req * * ) => *) + ;; this function checks if it's possible to do the transmission and + ;; if so, it takes the action in case of the possibility of a communication + ((chk_avail * * * *) => *) + ;; the next function uses chk_avail to see if it's possible to do a + ;; transmission it send back the st updated with the required + ;; action or leaves it as it is + ;; the check to decide wether the transmission will be done or not + ;; will be done in the scheduling function by looking at the state + ;; after the action has been taken by the next function + ;; the usage of the state only to make the decision is attractive + ;; however it means we imply the presence of a certain entry to + ;; change, thus we prefer two values as the result + ;; the result of the test + the updated state, in this case the + ;; user can use the result of the test and not the state + ((good_route? * * * * ) => (mv * *)) + ;; a cover fucntion used from the scheduling instance that calls + ;; the previous function + ((test_routes * *) => (mv * *)) + ;;a test function that will be used by the scheduling in the + ;;actual check to verify the condition for a communication + ;;and it sends back a true or nil + ((check_ack * * *) => *)) + + + (local + (defun req_trans (st) + ;;local witness + st)) + (local + ;;modify the name into ack_trans + (defun process_req (st dest) + (declare (ignore st dest)) + t)) + (local + (defun chk_avail (st org dest route) + (declare (ignore st)) + ;; this local witness is complicated for the simple reason that, + ;; one of the proof obligations needed to + ;;prove necessitate the definition of such witness + ;; the function checks three major conditions needed to verify + ;; that the origin of a message is different + ;;from its destination, last element of a route is equal to a route + ;; finally if the message is not arrived to its destination(route + ;; length equal 2), the next hop is not equal to the destination + ;; in instants of this function the user should provide the + ;; necessary extra conditions needed to schedule a travel + (and ;(if (equal (len route) 2) + ; t + ; (not (equal (cadr route) (car (last route))))) + (not (equal org (car (last (cdr route))))) + (equal (car (last (cdr route))) dest) + (no-hops-equal-to-dest route dest) + (no-consecutive-equals route)))) + + + (local + (defun good_route? (st org dest routes) + (if (endp routes) + (mv st nil) + (let ((route (car routes))) + (if (chk_avail st org dest route) + (mv st (car route)) + (good_route? st org dest (cdr routes))))))) + + (local + (defun test_routes (st tr) + (let* ((routes (routesv tr)) + (dest (car (last (car routes)))) + (org (orgv tr))) + (mv-let (newst r?) + (good_route? st org dest routes) + (mv newst r?) )))) + + (local + (defun check_ack (st cur dest) + (declare (ignore st cur dest)) + t)) + ;;proof obligations + ;; the result of req_trans is a valid state + (defthm state-req-trand + (implies (validstate ntkstate) + (validstate (req_trans ntkstate)))) + ;; the definition of chk_avail must guarantee the next three conditions + (defthm chk_avail_obligation-for-scheduling + (implies (chk_avail st org dest route) + (and ;(if (equal (len route) 2) t + ; (not (equal (cadr route) (car (last route))))) + ;(not (equal org (car (last (cdr route))))) + (equal (car (last (cdr route))) dest) + (no-hops-equal-to-dest route dest) + (no-consecutive-equals route))) + :rule-classes :forward-chaining) + ;; the result of good_route? is a valid state + (defthm validstate-good_route? + (implies (validstate ntkstate) + (validstate (mv-nth 0 (good_route? ntkstate org dest + routes))))) + ;; the result of test_route is a valid state + (defthm validdtate-test_routes + (implies (validstate ntkstate) + (validstate (mv-nth 0 (test_routes ntkstate tr)))) + :hints (("Goal" :in-theory (disable mv-nth)))))
\ No newline at end of file diff --git a/books/workshops/2009/verbeek-schmaltz/verbeek/generic-modules/GeNoC-types.lisp b/books/workshops/2009/verbeek-schmaltz/verbeek/generic-modules/GeNoC-types.lisp new file mode 100644 index 0000000..081f169 --- /dev/null +++ b/books/workshops/2009/verbeek-schmaltz/verbeek/generic-modules/GeNoC-types.lisp @@ -0,0 +1,552 @@ +#|$ACL2s-Preamble$; +;; Julien Schmaltz +;; Modified and updated by Amr HELMY 14th august 2007 +;; Definition of the data-types used in GeNoC: +;; Transactions, missives, travels, results and attempts +;; June 20th 2005 +;; File: GeNoC-types.lisp + +;;Amr helmy +;;31st october 2007 + +;; Rev. January 31st by JS (mainly state related functions) +(begin-book);$ACL2s-Preamble$|# + +(in-package "ACL2") + +;; book paths on my laptop +(include-book "data-structures/list-defuns" :dir :system) +(include-book "data-structures/list-defthms" :dir :system) +;(include-book "textbook/chap11/qsort" :dir :system) + +;;----------------------------------------------| +;; | +;; TRANSACTIONS | +;; | +;;----------------------------------------------| +;; A transaction is a tuple t = (id A msg B flits time) +;; Accessors are IdT, OrgT, MsgT, destT, FlitT, TimeT +;; TimeT represent the departure time of the flit + +(defun Idt (trans) + + (car trans)) +(defun OrgT (trans) (nth 1 trans)) +(defun MsgT (trans) (nth 2 trans)) +(defun DestT (trans) (nth 3 trans)) +(defun FlitT (trans) (nth 4 trans)) +(defun TimeT (trans) (nth 5 trans)) + + +(defun T-ids (Transts) + ;; function that grabs the ids of a list of trans. + (if (endp Transts) + nil + (append (list (caar Transts)) (T-ids (cdr Transts))))) + +(defun T-msgs (Trs) + ;; function that grabs the messages of a list of trans. + (if (endp Trs) + nil + (cons (MsgT (car trs)) + (T-msgs (cdr Trs))))) + +(defun T-orgs (Trs) + ;; function that grabs the origins of a list of trans + (if (endp Trs) + nil + (cons (OrgT (car trs)) + (T-orgs (cdr Trs))))) + +(defun T-dests (Trs) + ;; function that grabs the destinations of a list of trans + (if (endp Trs) + nil + (cons (DestT (car trs)) + (T-dests (cdr Trs))))) + +;; The following predicate checks that each transaction has +;; the right number of arguments +(defun validfield-transactionp (trans) + ;; trans = (id A msg B flits time) + (and (consp trans) + (consp (cdr trans)) ;; (A msg B flits Time) + (consp (cddr trans)) ;; (msg B flits Time) + (consp (cdddr trans)) ;; (B flits Time) + (consp (cddddr trans)) ;; (Flits Time) + (consp (cdr (cddddr trans))) ;(Time) + (null (cddr (cddddr trans))))) ;;nil + + +;; The following predicate recognizes a valid list of transactions +(defun Validfields-T (Transts) + (if (endp Transts) + t + (let ((trans (car Transts))) + (and (validfield-transactionp trans) + (natp (Idt trans)) ;; id is a natural + (MsgT trans) ;; msg /= nil + (Natp (FlitT trans)) + (natp (timeT trans)) + (not (equal (OrgT trans) (DestT trans))) ;; A /= B + (Validfields-T (cdr Transts)))))) + +;; now we define the predicate that recognizes a valid list of +;; transactions +(defun Transactionsp (Transts NodeSet) + (let ((T-ids (T-ids Transts))) + (and (Validfields-T Transts) + (true-listp Transts) + (subsetp (T-orgs Transts) NodeSet) + ;; the origins are members of the nodeset + (subsetp (T-dests Transts) NodeSet) + ;; the destinations are members of the nodeset + (No-Duplicatesp T-ids)))) + +;;------------------ end of Transactions ---------------------------------- + + +;;-----------------------------------------------| +;; | +;; MISSIVES | +;; | +;;-----------------------------------------------| + + +;; A missive is a tuple m = (id A frm B Flit Time) +;; Accessors are IdM, OrgM, FrmM and DestM + +(defun IdM (m) (car m)) +(defun OrgM (m) (nth 1 m)) +(defun FrmM (m) (nth 2 m)) +(defun DestM (m) (nth 3 m)) +(defun FlitM (m) (nth 4 m)) +(defun TimeM (m) (nth 5 m)) + + +;; We need a function that grabs the ids of a list of missives +(defun M-ids (M) + (if (endp M) + nil + (append (list (caar M)) (M-ids (cdr M))))) + +;; We need a function that grabs the origins of Missives +(defun M-orgs (M) + (if (endp M) + nil + (append (list (OrgM (car M))) (M-orgs (cdr M))))) + +;; The same for the destinations +(defun M-dests (M) + (if (endp M) + nil + (append (list (DestM (car M))) (M-dests (cdr M))))) + +;; We also need a function that grabs the frames of a list of missives +(defun M-frms (M) + (if (endp M) + nil + (let* ((msv (car M)) + (m-frm (FrmM msv))) + (append (list m-frm) (M-frms (cdr M)))))) + + +;; The following predicate checks that each missive has +;; the right number of arguments +(defun validfield-missivep (m) + ;; m = (id A frm B) + (and (consp m) + (consp (cdr m)) ;; (A frm B flits time) + (consp (cddr m)) ;; (frm B flits time) + (consp (cdddr m)) ;; (B flits time) + (consp (cddddr m)) ;; (Flits Time) + (consp (cdr (cddddr m))) ;;(time) + (null (cddr (cddddr m))))) ;;nil + +;; The following predicate recognizes a valid list of missives (partially) +(defun Validfields-M (M) + (if (endp M) + t + (let ((msv (car M))) + (and (validfield-missivep msv) + (natp (IdM msv)) ;; id is a natural + (FrmM msv) ;; frm /= nil + (natp (FlitM msv)) + (natp (TimeM msv)) + (not (equal (OrgM msv) (DestM msv))) ;; A /= B + (Validfields-M (cdr M)))))) + +;; now we define the predicate that recognizes a valid list of +;; missives +(defun Missivesp (M NodeSet) + (let ((M-ids (M-ids M))) + (and (Validfields-M M) + (subsetp (M-orgs M) NodeSet) ;;origins subset of nodeset + (subsetp (M-dests M) NodeSet) ;;destinations subset of nodeset + (true-listp M) + (No-Duplicatesp M-ids)))) + +;;-------------------- end of Missives ------------------------------------- + + +;;------------------------------------------| +;; | +;; TRAVELING MISSIVES | +;; | +;;------------------------------------------| + + +;; A traveling missive is a tuple m = (id A current frm B Flit time) +;; Accessors are IdTM, OrgTM, curTM, FrmTM and DestTM flitm + +(defun IdTM (m) (car m)) +(defun OrgTM (m) (nth 1 m)) +(defun CurTM (m) (nth 2 m)) +(defun FrmTM (m) (nth 3 m)) +(defun DestTM (m) (nth 4 m)) +(defun FlitTM (m) (nth 5 m)) +(defun TimeTM (m) (nth 6 m)) + +;; We need a function that grabs the ids of a list of missives +(defun TM-ids (M) + (if (endp M) + nil + (append (list (IdTM (car M))) (TM-ids (cdr M))))) + +;; We need a function that grabs the origins of Missives +(defun TM-orgs (M) + (if (endp M) + nil + (append (list (OrgTM (car M))) (TM-orgs (cdr M))))) + +;; The same for the currents +(defun TM-curs (M) + (if (endp M) + nil + (append (list (CurTM (car M))) (TM-curs (cdr M))))) + +;; The same for the destinations +(defun TM-dests (M) + (if (endp M) + nil + (append (list (DestTM (car M))) (TM-dests (cdr M))))) + +;; We also need a function that grabs the frames of a list of missives +(defun TM-frms (M) + ;; grabs the frames of M + (if (endp M) + nil + (let* ((msv (car M)) + (m-frm (FrmTM msv))) + (append (list m-frm) (TM-frms (cdr M)))))) + + +;; The following predicate checks that each missive has +;; the right number of arguments +(defun validfield-Tmissivep (m) + ;; m = (id A current frm B) + (and (consp m) + (consp (cdr m)) ;; (A current frm B flits time) + (consp (cddr m)) ;; (current frm B flits time) + (consp (cdddr m)) ;; (frm B flits time) + (consp (cddddr m)) ;; (B flits time) + (consp (cdr (cddddr m)));; (flits Time) + (consp (cddr (cddddr m))) ;;(time) + (null (cdddr (cddddr m))) + )) ;;nil + + + +;; The following predicate recognizes a valid list of missives (partially) +(defun Validfields-TM (M) + (if (endp M) + t + (let ((msv (car M))) + (and (validfield-Tmissivep msv) + (natp (IdTM msv)) ;; id is a natural + (FrmTM msv) ;; frm /= nil + (Natp (FlitTM msv)) + (natp (TimeTM msv)) + (not (equal (OrgTM msv) (DestTM msv))) ;; A /= B + (not (equal (CurTM msv) (DestTM msv))) ;; current /= B + (Validfields-TM (cdr M)))))) + +;; now we define the predicate that recognizes a valid list of +;; missives +(defun TMissivesp (M NodeSet) + (let ((M-ids (TM-ids M))) + (and (Validfields-TM M) + (subsetp (TM-orgs M) NodeSet) ;;origines subset nodeset + (subsetp (TM-curs M) NodeSet) ;;current subset nodeset + (subsetp (TM-dests M) NodeSet) ;;destination subset nodeset + (true-listp M) + (No-Duplicatesp M-ids)))) + +;;-------------------- end of Traveling Missives ------------------------- + + +;;------------------------------------------------| +;; | +;; TRAVELS | +;; | +;;------------------------------------------------| + +;; On ajoute l'origine, car elle va pouvoir ne plus apparaitre dans Routes... + +;; A travel is a tuple tr = (id org frm Routes flits time) +;; Accessors are IdV, OrgV, FrmV, RoutesV and FlitsV +;; (JS: V comes from the french word for travel, voyage :-) + +(defun IdV (tr) (car tr)) +(defun OrgV (m) (nth 1 m)) +(defun FrmV (tr) (nth 2 tr)) +(defun RoutesV (tr) (nth 3 tr)) +(defun FlitV (tr) (nth 4 tr)) +(defun TimeV (tr) (nth 5 tr)) + + +;; We need a function that grabs the ids of a list of travels +(defun V-ids (TrLst) + (if (endp TrLst) + nil + (append (list (caar TrLst)) (V-ids (cdr TrLst))))) + +;; We need a function that grabs the orgs of a list of travels +(defun V-orgs (TrLst) + (if (endp TrLst) + nil + (append (list (OrgV (car TrLst))) (V-orgs (cdr TrLst))))) + + +;; using these functions, we have: +;; (validfield-route route org dest) implies (validfield-route (cdr route) org dest) +;; for all routes in routes +(defun no-consecutive-equals (route) + (if (not (and (consp route) + (consp (cdr route)))) + t + (and (not (equal (car route) (cadr route))) + (no-consecutive-equals (cdr route))))) +(defun no-hops-equal-to-dest (route dest) + (if (not (and (consp route) + (consp (cdr route)))) + t + (and (not (equal (car route) dest)) + (no-hops-equal-to-dest (cdr route) dest)))) + +;; The following predicate checks that each route of routes +;; has at least two elements +(defun validfield-route (routes org nodeset) + ;; checks that every route has at least two elements + (if (endp routes) + t + (let ((r (car routes))) + (and (consp r) + (consp (cdr r)) + (subsetp r nodeset) + (not (equal org (car (last (cdr r))))) ;; (org != dest) +; (not (equal (car r) (car (last (cdr r))))) ;; (current != dest) + (no-consecutive-equals r) + (no-hops-equal-to-dest r (car (last r))) +; (or (equal (len r) 2) ;; or len = 2, or next != dest +; (not (equal (cadr r) (car (last r))))) + (validfield-route (cdr routes) org nodeset))))) + + +;; The following predicate checks that each travel has +;; the right number of arguments +(defun validfield-travelp (tr nodeset) + ;; tr = (id org frm Routes flits time) + (and (consp tr) + (consp (cdr tr)) ;; (org frm Routes flits time) + (consp (cddr tr)) ;; (frm Routes flits time) + (consp (cdddr tr)) ;; (Routes flits time) = ( ((R1) (R2) ...) flits time) + (consp (routesv tr)) + (consp (cddddr tr)) ;;(Flits Time) + (consp (cdr (cddddr tr))) ;; (time) + (null (cddr (cddddr tr))) ;;nil + (member-equal (orgv tr) nodeset) + (validfield-route (routesv tr) (orgv tr) nodeset))) + +;; The following predicate recognizes a valid list of missives (partially) +(defun Validfields-TrLst (TrLst nodeset) + (if (endp TrLst) + t + (let ((tr (car TrLst))) + (and (validfield-travelp tr nodeset) + (natp (IdV tr)) ;; id is a natural + (FrmV tr) ;; frm /= nil + (natp (FlitV tr)) + (natp (TimeV tr)) + (true-listp (RoutesV tr)) + (Validfields-TrLst (cdr TrLst) nodeset))))) + +;; now we define the predicate that recognizes a valid list of +;; travels +(defun TrLstp (TrLst nodeset) + (let ((V-ids (V-ids TrLst))) + (and (Validfields-TrLst TrLst nodeset) + (true-listp TrLst) + (No-Duplicatesp V-ids)))) + +(defun V-frms (TrLst) + ;; grabs the frames of TrLst + (if (endp TrLst) + nil + (let* ((tr (car Trlst)) + (v-frm (FrmV tr))) + (append (list v-frm) (V-frms (cdr TrLst)))))) + +;;-------------------- end of Travels ------------------------------------- + + +;;---------------------------------------------| +;; | +;; RESULTS | +;; | +;;---------------------------------------------| + +;; A result is a tuple rst = (Id Dest Msg flit Time) +;; Accessors are IdR, DestR and MsgR + +(defun IdR (rst) (car rst)) +(defun DestR (rst) (nth 1 rst)) +(defun MsgR (rst) (nth 2 rst)) +(defun FlitR (rst) (nth 3 rst)) +(defun TimeR (rst) (nth 4 rst)) + +(defun R-ids (R) + ;; function that grabs the ids of a list of results + (if (endp R) + nil + (append (list (caar R)) (R-ids (cdr R))))) + +(defun R-dests (Results) + ;; function that grabs the destinations of a list of results + (if (endp Results) + nil + (cons (DestR (car Results)) + (R-dests (cdr Results))))) + +(defun R-msgs (Results) + ;; function that grabs the messages of a list of results + (if (endp Results) + nil + (cons (MsgR (car results)) + (R-msgs (cdr Results))))) + + +;; The following predicate checks that each result has +;; the right number of arguments +(defun validfield-resultp (rst) + ;; tr = (Id Dest Msg) + (and (consp rst) + (consp (cdr rst)) ;; (Dest Msg Flit time) + (consp (cddr rst)) ;; (Msg Flit time) + (consp (cdddr rst)) ;; (flit time) + (consp (cddddr rst)) ;;(time) + (null (cdr(cddddr rst)))));; nil + + +;; The following predicate recognizes a valid list of results (partially) +(defun Validfields-R (R NodeSet) + (if (endp R) + t + (let ((rst (car R))) + (and (validfield-resultp rst) + (natp (IdR rst)) ;; id is a natural + (MsgR rst) ;; msg /= nil + (Natp (FlitR rst)) + (natp (TimeR rst)) + (member (DestR rst) NodeSet) + (Validfields-R (cdr R) NodeSet))))) + +;; now we define the predicate that recognizes a valid list of +;; results +(defun Resultsp (R NodeSet) + (let ((R-ids (R-ids R))) + (and (Validfields-R R NodeSet) + (true-listp R) + (No-Duplicatesp R-ids)))) + +;;-------------------- end of Results ------------------------------------- + +;;-----------------------------------------------| +;; | +;; STATE | +;; | +;;-----------------------------------------------| + +;; a state is a list of the form ( (coor (node_id)) (buffers ...)) where +;; node_id a an element of NodeSet +;; we define accessors and predicates defining valid state entries + +;; we need accessors to the state elements +(defun get_coor (st_entry) + ;; st_entry = ( (coor (id)) (buffers ...)) + ;; this function returns id + (cadar st_entry)) + + +(defun get_buff (st_entry) + ;; st_entry = ( (coor (id)) (buffers ...)) + ;; this function returns ... + (cadadr st_entry)) + + +(defun getcoordinates (ntkstate) + (if (endp ntkstate) + nil + (cons (get_coor (car ntkstate)) + (getcoordinates (cdr ntkstate))))) + +(defun get-buffers (ntkstate) + (if (endp ntkstate) + nil + (cons (get_buff (car ntkstate)) + (get-buffers (cdr ntkstate))))) + + +(defun validCoord (x) + ;; x is (coor (id)) + (and (equal (car x) 'Coor) + (consp x) + (consp (cdr x)) + (null (cddr x)))) + +(defun ValidBuffer (x) + ;; x is (buffers ...) + (and (equal (car x) 'Buffers) + (consp x) + (consp (cdr x)))) + +(defun ValidCoordlist (x) + ;; x is a state = ( ((coor (id)) (buffers ...)) ...) + (if (endp x) + t + (and (Validcoord (caar x)) + (Validcoordlist (cdr x))))) + +(defun ValidbuffersList (x) + ;; x is a state = ( ((coor (id)) (buffers ...)) ...) + (if (endp x) + t + (and (ValidBuffer (cadar x)) + (Validbufferslist (cdr x))))) + +;; NOTE: nil is a valid state, so nil is also a valid state element + +(defun validstate-entryp (st_entry) + (if (endp st_entry) + t + (and (Validcoord (car st_entry)) + (Validbuffer (cadr st_entry))))) + + +(defun ValidState (ntkstate) + (if (endp ntkstate) + t + (and ;(consp ntkstate) + (Validstate-entryp (car ntkstate)) + (Validstate (cdr ntkstate)))))#|ACL2s-ToDo-Line|# + diff --git a/books/workshops/2009/verbeek-schmaltz/verbeek/generic-modules/GeNoC.lisp b/books/workshops/2009/verbeek-schmaltz/verbeek/generic-modules/GeNoC.lisp new file mode 100644 index 0000000..cc9ad24 --- /dev/null +++ b/books/workshops/2009/verbeek-schmaltz/verbeek/generic-modules/GeNoC.lisp @@ -0,0 +1,2237 @@ +#|$ACL2s-Preamble$; +;; julien schmaltz +;; top level module of GeNoC +;; june 20th 2005 +;; file: GeNoC.lisp +;;Amr helmy +;;24st january 2008 +;;Edited 3rd march 2008 to add the round robin +(begin-book);$ACL2s-Preamble$|# + +(in-package "ACL2") + +(include-book "GeNoC-scheduling") +(include-book "GeNoC-routing") +(include-book "GeNoC-departure") +(include-book "GeNoC-simulation") +(in-theory (disable mv-nth)) + +(defun genoc_t (m nodeset measure trlst accup time ntkstate order) + ;; the composition of routing and scheduling is built by function genoc_t. + ;; it takes as arguments: + ;; - a list of missives, m + ;; - the set of existing nodes, nodeset + ;; - the measure provided by the scheduler + ;; - an accumulator of arrived messages + ;; - an accumulator of network states for simulation + ;; - the time + ;; - the state of the network + ;; - an ordering + ;; it returns: + ;; - the arrived messages + ;; - the en route messages + ;; - the network state accumulator + + ;; the measure is set to the measure defined by the scheduler + (declare (xargs :measure (acl2-count measure))) + (if (endp m) + ;; no more messages to send + (mv trlst nil accup) + ;; else + (mv-let (delayed departing) + ;; call R4D to determine which missives are ready for departure + (readyfordeparture m nil nil time) + ;; determine set of routes for all departing missives + (let ((v (routing departing nodeset))) + (cond ((not (legal-measure measure v nodeset ntkstate order)) + ;; illegal measure supplied + (mv trlst m accup)) + ;; check if it is possible to schedule + ((scheduling-assumptions v nodeset ntkstate order) + ;; schedule and recursivily call genoc_t + (mv-let (newtrlst arrived newmeasure newntkstate) + (scheduling v nodeset ntkstate order) + (genoc_t (append newtrlst delayed) + nodeset + newmeasure + (append arrived trlst) + (append accup (list (extract-simulation newntkstate))) + (+ 1 time) + newntkstate + (get_next_priority order)))) + (t + ;; scheduler has instructed to terminate + (mv trlst m accup))))))) + + + +;; correctness of genoc_t +;; ---------------------- +(defun correctroutes-genoc_t (routes m-dest) + ;; genoc_t is correct if every element ctr of the output list + ;; is such that (a) frmv(ctr) = frmtm(m) and (b) forall r in + ;; routesv(ctr) last(r) = desttm(m). for the m such that + ;; idm(m) = idv(ctr). + ;; this function checks that (b) holds. + (if (endp routes) + t + (let ((r (car routes))) + (and (equal (car (last r)) m-dest) + (correctroutes-genoc_t (cdr routes) m-dest))))) + +(defun genoc_t-correctness1 (trlst m/trlst) + ;; we complement the correctness of genoc_t + (if (endp trlst) + (if (endp m/trlst) + t + nil) + (let* ((tr (car trlst)) + (v-frm (frmv tr)) + (routes (routesv tr)) + (m (car m/trlst)) + (m-frm (frmm m)) + (m-dest (destm m))) + (and (equal v-frm m-frm) + (correctroutes-genoc_t routes m-dest) + (genoc_t-correctness1 (cdr trlst) (cdr m/trlst)))))) + +(defun genoc_t-correctness (trlst m) + ;; before checking correctness we filter m + ;; according to the ids of trlst + (let ((m/trlst (extract-sublst (tomissives m) (v-ids trlst)))) + (genoc_t-correctness1 trlst m/trlst))) + + +;; non tail definition of genoc_t +;; ------------------------------ +(defun genoc_t-non-tail-comp (m nodeset measure time ntkstate order) + (declare (xargs :measure (acl2-count measure))) + ;; we define a non tail function that computes the + ;; first output of genoc_t, i.e the completed transactions + (if (endp m) + nil + (mv-let (delayed departing) + (readyfordeparture m nil nil time) + (let ((v (routing departing nodeset))) + (cond ((not (legal-measure measure v nodeset ntkstate order)) + nil) + ((scheduling-assumptions v nodeset ntkstate order) + (mv-let (newtrlst arrived newmeasure newntkstate) + (scheduling v nodeset ntkstate order) + (append (genoc_t-non-tail-comp (append newtrlst delayed) + nodeset + newmeasure + (+ time 1) + newntkstate + (get_next_priority order)) + arrived))) + (t nil)))))) + +;; we now prove that this function is right + +(defthm true-listp-genoc_t-non-tail-comp ;; ok + (implies (true-listp m) + (true-listp (genoc_t-non-tail-comp m nodeset measure time ntkstate order))) + :rule-classes :type-prescription) + +(defthm genoc_t-non-tail-=-tail-comp ;; ok + (equal (mv-nth 0 (genoc_t m nodeset measure trlst accup time ntkstate order)) + (append (genoc_t-non-tail-comp m nodeset measure time ntkstate order) + trlst))) + + +;; proof of genoc_t correctness +;; ---------------------------- + +;; first we add a lemma that tells acl2 that +;; converting the travels that are routed and delayed +;; produced a valid list of missives +(defthm tmissivesp-mv-nth-0-scheduling-routing ;; ok + (let ((nodeset (nodesetgenerator params))) + (implies (and (tmissivesp m nodeset) + (validparamsp params)) + (tmissivesp (mv-nth 0 (scheduling (routing m nodeset) + nodeset ntkstate + order)) nodeset ))) + :hints (("goal" + :use ((:instance tmissivesp-mv-nth-0-scheduling + (trlst (routing m (nodesetgenerator params))))) + :in-theory (disable trlstp tmissivesp)))) + + +;; the next three theorems are to be moved in to the file GeNoC-misc +;; the recursive call of genoc_t-non-tail-comp calls append +;; we put the append at the top. +;; to do so we add the two rules below: + +(defthm v-ids-append + ;; the ids of an append is the append of the ids + (equal (v-ids (append a b)) + (append (v-ids a) (v-ids b)))) + +(defthm tm-ids-append + ;; the ids of an append is the append of the ids + (equal (tm-ids (append a b)) + (append (tm-ids a) (tm-ids b)))) + +(defthm extract-sublst-append + ;; filtering according to an append is the append + ;; of the filtering. + (equal (extract-sublst m (append id1 id2)) + (append (extract-sublst m id1) + (extract-sublst m id2)))) + + +;; then to split the proof is two cases, we replace the +;; append by a conjunction. +;; the rule below allows this decomposition: + +(defthm correctroutess1-append + (implies (and (equal (len a) (len c)) + (equal (len b) (len d))) + (equal (genoc_t-correctness1 (append a b) + (append c d)) + (and (genoc_t-correctness1 a c) + (genoc_t-correctness1 b d))))) + + + + +;; now we need to prove some lemmas so that previous rules +;; (from genoc-misc) about extract-sublst, tomissives, etc could +;; fire. + +;next thoerem is to prove that the append of the result of the +;scheduling to a a list of tmissives will result in a tmissives list + +(defthm sched-rout-missivesp-append + (implies (and (validparamsp params) + (not-in (tm-ids x) (tm-ids y)) + (tmissivesp x (nodesetgenerator params)) + (tmissivesp y (nodesetgenerator params))) + (tmissivesp + (append + (mv-nth 0 + (scheduling + (routing x (nodesetgenerator params)) + (nodesetgenerator params) ntkstate order)) y) + (nodesetgenerator params))) + :hints (("goal" + :use ((:instance tmissivesp-append-tmissivesp + (a (mv-nth 0 + (scheduling + (routing x + (nodesetgenerator + params)) + (nodesetgenerator + params) + ntkstate order))) + (b y)) + (:instance tmissivesp-newTrlst + (trlst (routing x (nodesetgenerator params)))) + (:instance trlstp-routing (m x)) + (:instance subsetp-arrived-newtrlst-ids + (trlst (routing x (nodesetgenerator params))) + (nodeset (nodesetgenerator params))) + (:instance ids-routing (m x)))))) + +(defthm v-ids-genoc_t-non-tail-comp ;; ok + ;; the ids of the output of genoc_t-non-tail-comp is a + ;; subset of those of m + ;; for this theorem the rule ids-routing is useful + (let ((nodeset (nodesetgenerator params))) + (implies (and (tmissivesp m nodeset) + (validparamsp params)) + (let ((gnt + (genoc_t-non-tail-comp m nodeset measure time ntkstate order))) + (subsetp (v-ids gnt) (tm-ids m))))) + :hints (("goal" + :in-theory + (disable mv-nth tmissivesp trlstp)) + ("subgoal *1/4" + :do-not '(eliminate-destructors generalize) + :use ((:instance tmissivesp-append-tmissivesp + (nodeset (nodesetgenerator params)) + (b (mv-nth 0 (readyfordeparture m nil nil time))) + (a (mv-nth 0 + (scheduling + (routing + (mv-nth + 1 + (readyfordeparture m nil nil + time)) + (nodesetgenerator params)) + (nodesetgenerator params) + ntkstate + order )))) + (:instance subsetp-arrived-newtrlst-ids + (trlst (routing (mv-nth 1 + (readyfordeparture + m nil nil time) ) + (nodesetgenerator + params))) + (nodeset (nodesetgenerator params))) + (:instance ids-routing (m (mv-nth 1 + (readyfordeparture + m nil nil + time))))) + :in-theory (disable mv-nth ids-routing + subsetp-arrived-newtrlst-ids + tmissivesp trlstp)) + ("subgoal *1/2" + :in-theory (disable TM-IDS-APPEND GENOC_T-NON-TAIL-COMP TMISSIVESP) + :use ((:instance ids-routing (m (mv-nth 1 + (readyfordeparture + m nil nil time)))) + (:instance tmissivesp-append-tmissivesp + (nodeset (nodesetgenerator params)) + (b (mv-nth 0 (readyfordeparture m nil nil time))) + (a (mv-nth 0 (scheduling + (routing + (mv-nth + 1 + (readyfordeparture m nil + nil + time)) + (nodesetgenerator params)) + (nodesetgenerator params) + ntkstate order)))))) + ("subgoal *1/2''" :in-theory (enable TM-IDS-APPEND GENOC_T-NON-TAIL-COMP TMISSIVESP)))) + + +(defthm not-in-v-ids-genoc_t-non-tail-comp ;; ok + ;; if the ids of a list have no common element with + ;; another ids then the output of genoc_t-non-tail-comp does + ;; not introduce any new id + (let ((nodeset (nodesetgenerator params))) + (implies (and (not-in (tm-ids delayed) sched-ids) + (tmissivesp delayed nodeset) + (validparamsp params)) + (not-in (v-ids (genoc_t-non-tail-comp delayed nodeset measure + time ntkstate + order)) + sched-ids))) + :otf-flg t + :hints (("goal" + :do-not-induct t + :in-theory (disable tmissivesp)))) + +(defthm v-ids-genoc_t-non-tail-comp-no-dup ;; ok + ;; the ids of the output of genoc_t-non-tail-comp have no dup + (let ((nodeset (nodesetgenerator params))) + (implies (and (tmissivesp m nodeset) + (validparamsp params)) + (let ((gnt (genoc_t-non-tail-comp m nodeset measure time + ntkstate order))) + (no-duplicatesp-equal (v-ids gnt))))) + :otf-flg t + :hints (("goal" + :do-not '(eliminate-destructors generalize) + :do-not-induct t + :induct (genoc_t-non-tail-comp m (nodesetgenerator params) + measure time ntkstate order) + :in-theory (disable tmissivesp trlstp )) + ("subgoal *1/3" + :use ((:instance trlstp-routing + (m (mv-nth 1 (readyfordeparture m nil nil time)))) + (:instance not-in->not-insched + (x (v-ids + (mv-nth + 1 + (scheduling + (routing + (mv-nth 1 + (readyfordeparture m nil + nil + time)) + (nodesetgenerator params)) + + (nodesetgenerator params) ntkstate order)))) + (y (tm-ids + (mv-nth 1 (readyfordeparture m nil nil time)))) + (z(tm-ids + (mv-nth 0 (readyfordeparture m nil nil time))))) + (:instance not-in-2->not-in-append + (x (tm-ids + (mv-nth 0 + (scheduling + (routing + (mv-nth + 1 (readyfordeparture m nil + nil + time)) + (nodesetgenerator params)) + + (nodesetgenerator params) + ntkstate order)))) + (y (tm-ids + (mv-nth 0 (readyfordeparture m nil nil time)))) + (z (v-ids + (mv-nth + 1 (scheduling + (routing (mv-nth + 1 + (readyfordeparture m nil + nil + time)) + (nodesetgenerator params)) + (nodesetgenerator params) + ntkstate order))))) + (:instance not-in-v-ids-genoc_t-non-tail-comp + (delayed + (append + (mv-nth + 0 + (scheduling + (routing (mv-nth + 1 + (readyfordeparture m nil nil time)) + (nodesetgenerator params)) + + (nodesetgenerator params) + ntkstate order)) + (mv-nth 0 + (readyfordeparture m nil nil time)))) + + (measure + (mv-nth + 2 + (scheduling + (routing (mv-nth + 1 + (readyfordeparture m nil nil + time)) + (nodesetgenerator params)) + (nodesetgenerator params) ntkstate order))) + (sched-ids + (v-ids + (mv-nth + 1 + (scheduling + (routing + (mv-nth 1 (readyfordeparture m nil + nil + time)) + (nodesetgenerator params)) + (nodesetgenerator params)ntkstate order)))) + (time (+ 1 time)) + (order (get_next_priority order)) + (ntkstate + (mv-nth + 3 + (scheduling + (routing + (mv-nth + 1 (readyfordeparture m nil nil time)) + (nodesetgenerator params)) + (nodesetgenerator params) ntkstate order)))) + (:instance not-in-1-0-ready-for-dept + (nodeset (nodesetgenerator params))) + (:instance subsetp-arrived-newtrlst-ids + (trlst (routing (mv-nth + 1 + (readyfordeparture m nil + nil + time)) + (nodesetgenerator params))) + (nodeset (nodesetgenerator params))) + (:instance not-in-newtrlst-arrived + (trlst (routing (mv-nth + 1 + (readyfordeparture m nil + nil + time)) + (nodesetgenerator params))) + (nodeset (nodesetgenerator params))) + (:instance trlstp-arrived + (trlst (routing (mv-nth 1 + (readyfordeparture + m nil nil time)) + (nodesetgenerator params))) + (nodeset (nodesetgenerator params)))) + :in-theory (e/d (trlstp) + (trlstp-arrived mv-nth trlstp + not-in-v-ids-genoc_t-non-tail-comp + tmissivesp))) + ("subgoal *1/2.3'" + :use ((:instance not-in-1-0-ready-for-dept-reverse + (nodeset (nodesetgenerator params))))))) + +;; move to GeNoC-misc +(defthm tmissivesp-extract-sublst + (let ((nodeset (nodesetgenerator params))) + (implies (and (tmissivesp m nodeset) + (validparamsp params) + (true-listp ids) + (no-duplicatesp-equal ids) + (subsetp ids (tm-ids m))) + (tmissivesp (extract-sublst m ids) nodeset))) + :hints (("goal" + :in-theory (disable tmissivesp)) + ("subgoal *1/1" + :in-theory (enable tmissivesp)))) +;; the following 7 theorems are intermediate lemmas to prove the +;; ultimate version +;; Tomissives-delayed-ultimate which is that too-missives newtrlst is +;; equal to tomissive to extract-sublst from the initial M based upon +;; the newtrlst's ids + +(defthm tomissives-delayed/rtg + ;; we prove that the conversion of the delayed travels + ;; into a list of missives is equal to the filtering + ;; of the initial list of missives m according to the ids + ;; of the delayed travels. + (let ((nodeset (nodesetgenerator params))) + (mv-let (newtrlst/rtg arrived/rtg newmeasure newntkstate) + (scheduling (routing m nodeset) nodeset ntkstate order) + (declare (ignore arrived/rtg newmeasure newntkstate)) + (implies (and (tmissivesp m nodeset) + (validparamsp params)) + (equal (tomissives newtrlst/rtg) + (extract-sublst (tomissives m) + (tm-ids newtrlst/rtg)))))) + :otf-flg t + :hints (("goal" + :do-not-induct t + :do-not '(eliminate-destructors generalize fertilize) + :use ((:instance totmissives-extract-sublst + (l (routing m (nodesetgenerator params))) + (ids (tm-ids + (mv-nth + 0 (scheduling + (routing m (nodesetgenerator params)) + (nodesetgenerator params) + ntkstate order))))) + (:instance newtrlst-travel-correctness + (trlst (routing m (nodesetgenerator params))) + (nodeset (nodesetgenerator params))) + (:instance subsetp-arrived-newtrlst-ids + (trlst (routing m (nodesetgenerator params))) + (nodeset (nodesetgenerator params)))) + :in-theory (disable binary-append nth-with-large-index + extract-sublst tm-ids + member-equal-tm-ids-assoc-equal + tomissives m-ids assoc-equal trlstp + missivesp totmissives-extract-sublst + len subsetp-arrived-newtrlst-ids)))) + +(defthm newtrlst-subsetp-ready-4-dept + (let ((nodeset (nodesetgenerator params))) + (mv-let (newtrlst/rtg arrived/rtg newmeasure newntkstate) + (scheduling + (routing (mv-nth 1 + (readyfordeparture m nil nil time)) + nodeset) + nodeset ntkstate order) + (declare (ignore arrived/rtg newmeasure newntkstate)) + (implies (and (tmissivesp m nodeset) + (validparamsp params)) + (subsetp(tm-ids newtrlst/rtg) + (tm-ids (extract-sublst + m + (tm-ids + (mv-nth + 1 + (readyfordeparture m + nil + nil + time))))))))) + :hints (("goal" + :in-theory (disable tm-orgs extract-sublst m-ids + idm nfix m-ids + mv-nth-0-scheduling-on-zero-measure + id-not-eq-car-member-cdr-missives + assoc-equal + subset-ready-for-departure-3 + not-in-1-0-ready-for-dept + NO-DUPLICATESP + checkroutes-subsetp-validroute + true-listp-mv-nth-1-sched-2 + subset-ready-for-departure-2 + true-listp-last last consp-last + subsetp-arrived-newtrlst-ids + len nth tmissivesp-extract-sublst + tmissivesp-extract trlstp-routing + true-listp + leq-position-equal-len + member-equal-m-ids-assoc-equal v-ids + nfix ) + + :use ((:instance subsetp-arrived-newtrlst-ids + (trlst + (routing (mv-nth + 1 + (readyfordeparture m nil nil + time)) + (nodesetgenerator params))) + (nodeset (nodesetgenerator params))) + (:instance trlstp-routing + (m (mv-nth 1 (readyfordeparture m nil nil time)))) + (:instance subset-ready-for-departure-3 + (nodeset (nodesetgenerator params))) + (:instance tmissivesp-ready-4-departure-mv-1 + (nodeset (nodesetgenerator params))) + (:instance subset-ready-for-departure-2 + (nodeset (nodesetgenerator params))) + (:instance tmissivesp-equal-subsetp + (nodeset (nodesetgenerator params)) + (x (mv-nth 1 (readyfordeparture m nil nil + time))) + (y m)) + (:instance tmissivesp-ready-4-departure-mv-1 + (nodeset (nodesetgenerator params))))))) + + + + +(defthm newtrlst-subsetp-M + (let ((nodeset (nodesetgenerator params))) + (mv-let (newtrlst/rtg arrived/rtg new newntkstate) + (scheduling (routing (mv-nth 1 (readyfordeparture m nil nil time)) nodeset) nodeset ntkstate order) + (declare (ignore arrived/rtg new newntkstate)) + (implies (and (tmissivesp m nodeset) + (validparamsp params)) + (subsetp (tm-ids newtrlst/rtg) (tm-ids m))))) + :hints (("goal" + :in-theory (disable extract-sublst + m-ids + mv-nth-0-scheduling-on-zero-measure + assoc-equal + subset-ready-for-departure-3 + not-in-1-0-ready-for-dept + checkroutes-subsetp-validroute + true-listp-mv-nth-1-sched-2 + len nth tmissivesp-extract-sublst + tmissivesp-extract + leq-position-equal-len + member-equal-m-ids-assoc-equal v-ids + nfix ) + :use + ((:instance tmissivesp-ready-4-departure-mv-1 + (nodeset (nodesetgenerator params))) + (:instance subsetp-arrived-newtrlst-ids + (trlst (routing + (mv-nth + 1 + (readyfordeparture m nil nil time)) + (nodesetgenerator params))) + (nodeset (nodesetgenerator params))) + (:instance trlstp-routing + (m (mv-nth 1 (readyfordeparture + m nil nil time)))) + (:instance subset-ready-for-departure-2 + (nodeset (nodesetgenerator params))))))) + +(defthm taking-the-to-missives-out + (let ((nodeset (nodesetgenerator params))) + (mv-let (newtrlst/rtg arrived/rtg newmeasure newntkstate) + (scheduling + (routing + (mv-nth + 1 + (readyfordeparture m nil nil time)) nodeset) + nodeset ntkstate order) + (declare (ignore arrived/rtg newmeasure newntkstate)) + (implies (and (tmissivesp m nodeset) + (validparamsp params)) + (equal + (extract-sublst + (tomissives + (extract-sublst + m + (tm-ids (mv-nth + 1 + (readyfordeparture m nil nil time))))) + (tm-ids newtrlst/rtg)) + (tomissives + (extract-sublst + (extract-sublst + m + (tm-ids (mv-nth 1 (readyfordeparture m nil + nil + time)))) + (tm-ids newtrlst/rtg))))))) + :hints (("goal" + :in-theory (disable tmissivesp tomissives-extract-sublst) + :use + ((:instance tomissives-extract-sublst + (nodeset (nodesetgenerator params)) + (ids (tm-ids + (mv-nth + 0 + (scheduling + (routing + (mv-nth 1 (readyfordeparture m nil nil time)) + (nodesetgenerator params)) + (nodesetgenerator params) ntkstate order)))) + (l (extract-sublst + m (tm-ids + (mv-nth + 1 + (readyfordeparture m nil nil time)))))) + (:instance subset-ready-for-departure-2 + (nodeset (nodesetgenerator params))) + (:instance subset-ready-for-departure-3 + (nodeset (nodesetgenerator params))) + (:instance tmissivesp-extract + (ids (tm-ids + (mv-nth 1 (readyfordeparture m nil nil time)))) + (nodeset (nodesetgenerator params))) + (:instance tmissivesp-ready-4-departure-mv-1 + (nodeset (nodesetgenerator params))))) + ("subgoal 2" :in-theory (disable tmissivesp) + :use + ((:instance tmissivesp-ready-4-departure-mv-1 + (nodeset (nodesetgenerator params))) + (:instance subset-ready-for-departure-2 + (nodeset (nodesetgenerator params))) + (:instance subset-ready-for-departure-3 + (nodeset (nodesetgenerator params))) + (:instance tmissivesp-extract + (ids + (tm-ids + (mv-nth 1 (readyfordeparture m nil nil time)))) + (nodeset (nodesetgenerator params))))) + ("subgoal 3" + :use + ((:instance subsetp-arrived-newtrlst-ids + (trlst (routing + (mv-nth 1 (readyfordeparture m nil nil + time)) + (nodesetgenerator params))) + (nodeset (nodesetgenerator params))) + (:instance trlstp-routing + (m (mv-nth 1 (readyfordeparture m nil nil time)))) + (:instance ids-routing + (m (mv-nth 1 (readyfordeparture m nil nil time)))) + (:instance tmissivesp-ready-4-departure-mv-1 + (nodeset (nodesetgenerator params))))))) + +(defthm tomissives-delayed-intermediate-2 + (let ((nodeset (nodesetgenerator params))) + (mv-let (newtrlst/rtg arrived/rtg newmeasure newntkstate) + (scheduling (routing (mv-nth 1 (readyfordeparture m nil + nil + time)) + nodeset) nodeset ntkstate order) + (declare (ignore arrived/rtg newmeasure newntkstate)) + (implies (and (tmissivesp m nodeset) + (validparamsp params)) + (equal (tomissives newtrlst/rtg) + (extract-sublst + (tomissives + (extract-sublst + m + (tm-ids + (mv-nth + 1 (readyfordeparture m nil nil time))))) + (tm-ids newtrlst/rtg)))))) + :hints (("goal" + :in-theory (disable TOMISSIVES LEN NTH-WITH-LARGE-INDEX TM-IDS + nth assoc-equal MEMBER-EQUAL-TM-IDS-ASSOC-EQUAL + MEMBER-EQUAL-M-IDS-ASSOC-EQUAL M-IDS) + :use ((:instance tmissivesp-equal-subsetp + (y m) + (nodeset (nodesetgenerator params)) + (x (mv-nth 1 (readyfordeparture m nil nil time)))) + (:instance subset-ready-for-departure-3 + (nodeset (nodesetgenerator params))) + (:instance tmissivesp-ready-4-departure-mv-1 + (nodeset (nodesetgenerator params))))))) + +(defthm tomissives-delayed-ultimate + (let ((nodeset (nodesetgenerator params))) + (mv-let (newtrlst/rtg arrived/rtg newmeasure newntkstate) + (scheduling (routing (mv-nth 1 (readyfordeparture m nil + nil + time)) + nodeset) nodeset ntkstate order) + (declare (ignore arrived/rtg newmeasure newntkstate)) + (implies (and (tmissivesp m nodeset) + (validparamsp params)) + (equal (tomissives newtrlst/rtg) + (tomissives + (extract-sublst m (tm-ids newtrlst/rtg))))))) + :hints (("goal" + :use ((:instance subsetp-arrived-newtrlst-ids + (trlst + (routing + (mv-nth 1 + (readyfordeparture m nil nil + time)) + (nodesetgenerator params))) + (nodeset (nodesetgenerator params))) + (:instance trlstp-routing + (m (mv-nth 1 + (readyfordeparture m nil nil time)))) + (:instance extract-sublst-cancel-tm + (id1 (tm-ids + (mv-nth + 1 (readyfordeparture m nil nil time)))) + (id2 (tm-ids newtrlst/rtg))) + (:instance tmissivesp-ready-4-departure-mv-1 + (nodeset (nodesetgenerator params))))))) + +(defthm tomissives-delayed-ultimate-bis + (let ((nodeset (nodesetgenerator params))) + (mv-let (newtrlst/rtg arrived/rtg newmeasure newntkstate) + (scheduling (routing (mv-nth 1 (readyfordeparture m nil + nil + time)) + nodeset) nodeset ntkstate order) + (declare (ignore arrived/rtg newmeasure newntkstate)) + (implies (and (tmissivesp m nodeset) + (validparamsp params)) + (equal (tomissives newtrlst/rtg) + (extract-sublst (tomissives m ) + (tm-ids newtrlst/rtg)))))) + :hints (("goal" + :in-theory (disable subset-ready-for-departure-2 + idm tm-curs + tm-orgs id-not-eq-car-member-cdr + leq-position-equal-len default-car + mv-nth-0-scheduling-on-zero-measure + nth-with-large-index tmissivesp + true-listp-mv-nth-1-sched-2 + validfield-route m-ids nfix + default-cdr + tomissives-extract-sublst + id-not-eq-car-member-cdr-missives m-ids + member-equal-tm-ids-assoc-equal + len tomissives-delayed-ultimate len + assoc-equal member-equal-m-ids-assoc-equal) + :use + ((:instance subsetp-arrived-newtrlst-ids + (trlst + (routing + (mv-nth 1 (readyfordeparture m nil nil time)) + (nodesetgenerator params))) + (nodeset (nodesetgenerator params))) + (:instance subset-ready-for-departure-2 + (nodeset (nodesetgenerator params))) + (:instance trlstp-routing + (m (mv-nth 1 (readyfordeparture m nil nil time)))) + (:instance tomissives-extract-sublst + (nodeset (nodesetgenerator params)) + (l m) + (ids(tm-ids + (mv-nth + 0 + (scheduling + (routing + (mv-nth + 1 (readyfordeparture m nil nil time)) + (nodesetgenerator params)) + (nodesetgenerator params) ntkstate order))))) + (:instance tmissivesp-ready-4-departure-mv-1 + (nodeset (nodesetgenerator params))))))) + +(defthm v-ids_g_nt_sigma_subsetp-v-ids-newtrlst/rtg ;; ok + ;; this lemma is used in the subsequent proofs + ;; it makes a fact "explicit" + (let ((nodeset (nodesetgenerator params))) + (mv-let (newtrlst arrived newmeasure newntkstate) + (scheduling (routing m nodeset) nodeset ntkstate order) + (declare (ignore arrived newntkstate)) + (implies (and (tmissivesp m nodeset) + (validparamsp params)) + (subsetp + (v-ids + (genoc_t-non-tail-comp + (extract-sublst m (tm-ids newtrlst)) + nodeset newmeasure time ntkstate order)) + (tm-ids newtrlst))))) + :otf-flg t + :hints (("goal" + :do-not-induct t + :use ((:instance subsetp-arrived-newtrlst-ids + (trlst (routing m (nodesetgenerator params))) + (nodeset (nodesetgenerator params))) + (:instance tmissivesp-newTrlst + (trlst (routing m (nodesetgenerator params))) + (nodeset (nodesetgenerator params))) + (:instance tmissivesp-extract-sublst + (ids (tm-ids (mv-nth + 0 + (scheduling + (routing m + (nodesetgenerator params)) + + (nodesetgenerator + params) + ntkstate order))))) + (:instance fwd-tmissivesp + (nodeset (nodesetgenerator params))) + ;; the following is required because in the conclusion of the + ;; rule there is call to extract-sublst + (:instance v-ids-genoc_t-non-tail-comp + (m + (extract-sublst + m + (tm-ids + (mv-nth + 0 + (scheduling + (routing m (nodesetgenerator params)) + (nodesetgenerator params) + ntkstate order))))) + (measure (mv-nth + 2 + (scheduling + (routing m (nodesetgenerator params)) + (nodesetgenerator params) + ntkstate order))))) + :in-theory (disable subsetp-arrived-newtrlst-ids + mv-nth-0-scheduling-on-zero-measure + binary-append len tmissivesp-newtrlst + v-ids-genoc_t-non-tail-comp tm-ids nfix + trlstp tmissivesp)))) + +;; arrived/rtg does not modify frames +;; --------------------------------------- + +(defthm s/d-travel-v-frms + (implies (and (trlstp sd-trlst nodeset) + (s/d-travel-correctness sd-trlst trlst/sd-ids)) + (equal (v-frms sd-trlst) (v-frms trlst/sd-ids)))) + +(defthm arrived-v-frms-m-frms ;; ok + ;; we prove that the frames of the scheduled travels + ;; are equal to the frames of the conversion of the initial list of travels + ;; filtered according to the ids of the scheduled travels + (mv-let (newtrlst arrived newmeasure newntkstate) + (scheduling trlst nodeset ntkstate order) + (declare (ignore newtrlst newmeasure newntkstate)) + (implies (and (trlstp trlst nodeset) + (validparamsp params)) + (equal (v-frms arrived) + (tm-frms + (totmissives + (extract-sublst trlst (v-ids arrived))))))) + :hints (("goal" + :use ((:instance tm-frms-to-v-frms + (x (extract-sublst + trlst + (v-ids (mv-nth + 1 (scheduling trlst + nodeset ntkstate + order)))))) + (:instance s/d-travel-v-frms + (sd-trlst (mv-nth 1 (scheduling trlst + nodeset + ntkstate + order))) + (trlst/sd-ids (extract-sublst + trlst + (v-ids + (mv-nth + 1 + (scheduling trlst + + nodeset + ntkstate order)))))) + + (:instance arrived-travels-correctness)) + :in-theory (disable trlstp s/d-travel-v-frms mv-nth)))) + + +(defthm arrived/rtg_not_modify_frames ;; ok + ;; we prove the the frames of the arrived travels produced + ;; by scheduling and routing are equal to the frames + ;; of the initial list of missives + (let ((nodeset (nodesetgenerator params))) + (mv-let (newtrlst arrived newmeasure newntkstate) + (scheduling (routing m nodeset) nodeset ntkstate order) + (declare (ignore newtrlst newmeasure newntkstate)) + (implies (and (tmissivesp m nodeset) + (validparamsp params)) + (equal (v-frms arrived) + (tm-frms + (extract-sublst + m (v-ids arrived))))))) + :hints (("goal" + :do-not-induct t + :do-not '(eliminate-destructors generalize ) + :use ((:instance arrived-v-frms-m-frms + (trlst (routing m (nodesetgenerator params))) + (nodeset (nodesetgenerator params))) + (:instance subsetp-arrived-newtrlst-ids + (trlst (routing m (nodesetgenerator params))) + (nodeset (nodesetgenerator params)))) + :in-theory (disable trlstp tmissivesp + subsetp-arrived-newtrlst-ids + arrived-v-frms-m-frms)) + ("subgoal 1" + :use ((:instance totmissives-extract-sublst + (l (routing m (nodesetgenerator params))) + (ids (v-ids + (mv-nth + 1 + (scheduling + (routing m (nodesetgenerator params)) + (nodesetgenerator params) + ntkstate order)))) + (nodeset (nodesetgenerator params)))) + :in-theory (disable trlstp tmissivesp + subsetp-arrived-newtrlst-ids + arrived-v-frms-m-frms ids-routing)))) + + +(defthm correctroutesp-vm-frms-gc1 ;; ok + ;; the correctness of routes and equality of frames imply + ;; the main predicate (correctness of genoc_t-non-tail-comp) + (implies (and (correctroutesp l (extract-sublst m (v-ids l)) + nodeset) + (equal (v-frms l) + (tm-frms (extract-sublst m (v-ids l))))) + (genoc_t-correctness1 l + (tomissives (extract-sublst m (v-ids l))))) + + :hints (("Goal" :in-theory (disable len nfix assoc-equal + member-equal-tm-ids-assoc-equal + member-equal-m-ids-assoc-equal + true-listp-member-equal)))) + + +(defthm gc1_arrived/rtg ;; ok + ;; we prove the correctness of the arrived travels + (let ((nodeset (nodesetgenerator params))) + (implies (and (tmissivesp m nodeset) + (validparamsp params)) + (mv-let (newtrlst arrived newmeasure newntkstate) + (scheduling (routing m nodeset) nodeset + ntkstate order) + (declare (ignore newtrlst newmeasure newntkstate)) + (genoc_t-correctness1 + arrived + (tomissives (extract-sublst m (v-ids arrived))))))) + :otf-flg t + :hints (("goal" + :do-not-induct t + :do-not '(eliminate-destructors generalize ) + :use + ((:instance subsetp-arrived-newtrlst-ids + (trlst (routing m (nodesetgenerator params))) + (nodeset (nodesetgenerator params))) + (:instance totmissives-extract-sublst + (l (routing m (nodesetgenerator params))) + (ids (v-ids + (mv-nth + 1 + (scheduling + (routing m (nodesetgenerator params)) + + (nodesetgenerator params) ntkstate order)))) + (nodeset (nodesetgenerator params))) + (:instance scheduling-preserves-route-correctness + (nodeset (nodesetgenerator params)) + (trlst (routing m (nodesetgenerator params)))) + (:instance correctroutesp-vm-frms-gc1 + (nodeset (nodesetgenerator params)) + (l (mv-nth + 1 + (scheduling + (routing m (nodesetgenerator params)) + (nodesetgenerator params) ntkstate order))))) + :in-theory (disable trlstp tmissivesp + correctroutesp-vm-frms-gc1 len + subsetp-arrived-newtrlst-ids + scheduling-preserves-route-correctness + arrived/rtg_not_modify_frames)))) + +;;tomissives of scheduling + tomissives of ready 0 ----> tomissives m + +(defthm lemma12 + (let ((nodeset (nodesetgenerator params)) + (mv0-sched (mv-nth + 0 + (scheduling + (routing (mv-nth 1 (readyfordeparture m nil nil + time)) + (nodesetgenerator params)) + (nodesetgenerator params) ntkstate order))) + (mv3-sched (mv-nth + 2 + (scheduling + (routing (mv-nth 1 (readyfordeparture m nil nil + time)) + (nodesetgenerator params)) + (nodesetgenerator params) ntkstate order))) + (mv4-sched (mv-nth + 3 + (scheduling + (routing (mv-nth 1 (readyfordeparture m nil nil + time)) + (nodesetgenerator params)) + (nodesetgenerator params) ntkstate order))) + (mv0-r4d (mv-nth 0 (readyfordeparture m nil nil time))) + (order1 (get_next_priority order))) + (implies (and (tmissivesp m nodeset) + (validparamsp params)) + (equal + (extract-sublst (append + (extract-sublst (tomissives m) + (tm-ids mv0-sched)) + (extract-sublst (tomissives m) + (tm-ids mv0-r4d))) + (v-ids + (genoc_t-non-tail-comp + (append mv0-sched mv0-r4d) nodeset + mv3-sched + (+ 1 time) mv4-sched order1))) + (extract-sublst (tomissives m) + (v-ids (genoc_t-non-tail-comp + (append mv0-sched mv0-r4d) + nodeset mv3-sched (+ 1 time) + mv4-sched + order1)))))) + + :hints (("goal" :use + ((:instance v-ids-genoc_t-non-tail-comp + (m (append (mv-nth + 0 + (scheduling + (routing + (mv-nth + 1 + (readyfordeparture m nil nil + time)) + (nodesetgenerator params)) + (nodesetgenerator params) + ntkstate order)) + (mv-nth + 0 + (readyfordeparture m nil nil time)))) + (measure (mv-nth + 2 + (scheduling + (routing (mv-nth + 1 (readyfordeparture m nil nil + time)) + (nodesetgenerator params)) + (nodesetgenerator params) ntkstate order))) + (time (+ 1 time)) + (order (get_next_priority order)) + (ntkstate + (mv-nth + 3 + (scheduling + (routing + (mv-nth 1 (readyfordeparture m nil nil + time)) + (nodesetgenerator params)) + (nodesetgenerator params) ntkstate order)))) + (:instance equalid-tomissives + (nodeset (nodesetgenerator params))) + (:instance tm-ids-append-invert + (nodeset (nodesetgenerator params)) + (a (mv-nth + 0 + (scheduling + (routing (mv-nth + 1 + (readyfordeparture m nil nil + time)) + (nodesetgenerator params)) + (nodesetgenerator params) ntkstate order))) + (b (mv-nth 0 (readyfordeparture m nil nil time)))) + (:instance newtrlst-travel-correctness + (nodeset (nodesetgenerator params)) + (trlst (routing + (mv-nth 1 + (readyfordeparture m nil nil + time)) + (nodesetgenerator params)))) + (:instance subsetp-arrived-newtrlst-ids + (trlst (routing + (mv-nth 1 (readyfordeparture m nil nil + time)) + (nodesetgenerator params))) + (nodeset (nodesetgenerator params))) + (:instance extract-sublst-cancel-m + (m (tomissives m)) + (id1 (tm-ids (append + (mv-nth + 0 + (scheduling + (routing + (mv-nth + 1 + (readyfordeparture m nil nil + time)) + (nodesetgenerator params)) + (nodesetgenerator params) + ntkstate order)) + (mv-nth + 0 + (readyfordeparture m nil nil time))) )) + (id2 (v-ids (genoc_t-non-tail-comp + (append (mv-nth + 0 + (scheduling + (routing + (mv-nth + 1 + (readyfordeparture m + nil + nil + time)) + (nodesetgenerator params)) + (nodesetgenerator + params) + ntkstate order)) + (mv-nth + 0 + (readyfordeparture m nil + nil + time))) + (nodesetgenerator params) + (mv-nth 2 + (scheduling + (routing + (mv-nth + 1 + (readyfordeparture m + nil + nil + time)) + (nodesetgenerator params)) + (nodesetgenerator + params) + ntkstate order)) + (+ 1 time) + (mv-nth + 3 + (scheduling + (routing + (mv-nth + 1 + (readyfordeparture m nil nil + time)) + (nodesetgenerator params)) + (nodesetgenerator params) + ntkstate order)) + (get_next_priority order ))))) + (:instance tmissivesp-ready-4-departure-mv-0 + (nodeset (nodesetgenerator params))) + (:instance trlstp-routing + (m (mv-nth 1 (readyfordeparture m nil nil time)))) + (:instance tmissivesp-append-tmissivesp + (a (mv-nth 0 + (scheduling + (routing + (mv-nth + 1 (readyfordeparture m nil nil time)) + (nodesetgenerator params)) + (nodesetgenerator params) ntkstate + order))) + (b (mv-nth 0 (readyfordeparture m nil nil time))) + (nodeset (nodesetgenerator params))) + (:instance v-ids_g_nt_sigma_subsetp-v-ids-newtrlst/rtg + (m (append + (mv-nth + 0 + (scheduling + (routing + (mv-nth + 1 (readyfordeparture m nil nil time)) + (nodesetgenerator params)) + (nodesetgenerator params) ntkstate + order)) + (mv-nth 0 (readyfordeparture m nil nil time))) )) + (:instance tmissivesp-ready-4-departure-mv-1 + (nodeset (nodesetgenerator params))) + (:instance not-in-1-0-ready-for-dept-reverse + (nodeset (nodesetgenerator params))) + (:instance not-in-1-0-ready-for-dept + (nodeset (nodesetgenerator params))) + (:instance tmissivesp-newTrlst + (trlst (routing + (mv-nth 1 + (readyfordeparture m nil nil time)) + (nodesetgenerator params))) + (nodeset (nodesetgenerator params))))))) + + +(defthm lemma12final + (let ((nodeset (nodesetgenerator params)) + (mv0-sched + (mv-nth + 0 + (scheduling + (routing + (mv-nth + 1 (readyfordeparture m nil nil time)) + (nodesetgenerator params)) + (nodesetgenerator params) ntkstate order))) + (mv3-sched + (mv-nth + 2 + (scheduling + (routing + (mv-nth + 1 (readyfordeparture m nil nil time)) + (nodesetgenerator params)) + (nodesetgenerator params) ntkstate order))) + (mv4-sched + (mv-nth + 3 + (scheduling + (routing + (mv-nth + 1 (readyfordeparture m nil nil time)) + (nodesetgenerator params)) + (nodesetgenerator params) ntkstate order))) + (mv0-r4d (mv-nth 0 (readyfordeparture m nil nil time)))) + (implies (and (tmissivesp m nodeset) + (validparamsp params)) + (equal + (extract-sublst + (append (extract-sublst (tomissives m) + (tm-ids mv0-sched)) + (tomissives mv0-r4d)) + (v-ids + (genoc_t-non-tail-comp + (append mv0-sched mv0-r4d) nodeset mv3-sched + (+ 1 time) mv4-sched (get_next_priority order)))) + (extract-sublst + (tomissives m) + (v-ids + (genoc_t-non-tail-comp + (append mv0-sched mv0-r4d) nodeset mv3-sched (+ 1 + time) + mv4-sched (get_next_priority order))))))) + :hints (("goal" + :in-theory (e/d () (tmissivesp + checkroutes-subsetp-validroute + m-ids-append-invert + nil-r4d-nil-mv0 nil-r4d-nil-mv1 zp + ; true-listp-genoc_t-non-tail-comp + tomissives + member-equal-tm-ids-assoc-equal + member-equal-m-ids-assoc-equal tm-ids + assoc-equal m-ids)) + :use ((:instance lemma12) + (:instance subset-ready-for-departure-4 + (nodeset (nodesetgenerator params))) + (:instance tmissivesp-ready-4-departure-mv-0 + (nodeset (nodesetgenerator params))) + (:instance tmissivesp-equal-subsetp + (nodeset (nodesetgenerator params)) + (y m) + (x (mv-nth 0 (readyfordeparture m nil nil time)))) + (:instance tmissives-subset-extract-tomissives-equal + (nodeset (nodesetgenerator params)) + (x m) + (ids (tm-ids + (mv-nth + 0 + (readyfordeparture m nil nil time))))) + (:instance subset-ready-for-departure + (nodeset (nodesetgenerator params))) + (:instance subset-ready-for-departure-4 + (nodeset (nodesetgenerator params))) + (:instance tmissivesp-ready-4-departure-mv-0 + (nodeset (nodesetgenerator params))))))) + +(defthm takingtomissivesout-equal + (let ((nodeset (nodesetgenerator params)) + (mv1-sched (mv-nth + 1 + (scheduling + (routing + (mv-nth 1 (readyfordeparture m nil nil time)) + (nodesetgenerator params)) + (nodesetgenerator params) ntkstate order)))) + (implies (and (tmissivesp M nodeset) + (validparamsp params)) + (equal + (tomissives + (extract-sublst (mv-nth 1 (readyfordeparture m nil nil time)) + (v-ids mv1-sched))) + (extract-sublst (tomissives + (mv-nth 1 (readyfordeparture m nil nil time))) + (v-ids mv1-sched))))) + + :hints (("goal" + :use ((:instance tmissivesp-equal-subsetp + (x (mv-nth 1 (readyfordeparture m nil nil time))) + (nodeset (nodesetgenerator params)) + (y m)) + (:instance ToMissives-extract-sublst + (L (extract-sublst + m + (tm-ids (mv-nth + 1 + (readyfordeparture m nil nil time))))) + (ids (v-ids + (mv-nth + 1 + (scheduling + (routing + (mv-nth + 1 (readyfordeparture m nil nil time)) + (nodesetgenerator params)) + (nodesetgenerator params) + ntkstate order)))) + (nodeset (nodesetgenerator params))) + (:instance subsetp-arrived-newtrlst-ids + (trlst (routing + (mv-nth + 1 + (readyfordeparture m nil nil + time)) + (nodesetgenerator params))) + (nodeset (nodesetgenerator params))))))) + + + +(defthm lemma121final + (let ((nodeset (nodesetgenerator params)) + (mv1-sched (mv-nth + 1 + (scheduling + (routing + (mv-nth + 1 (readyfordeparture m nil nil time)) + (nodesetgenerator params)) + (nodesetgenerator params) ntkstate order)))) + (implies (and (tmissivesp M nodeset) + (validparamsp params)) + (equal + (extract-sublst + (tomissives (mv-nth 1 (readyfordeparture m nil nil time))) + (v-ids mv1-sched)) + (tomissives (extract-sublst M (v-ids mv1-sched)))))) + :hints (("Goal" + :in-theory (disable tmissivesp len) + :do-not-induct t + :use ((:instance extract-sublst-cancel-TM + (id1 (TM-ids + (mv-nth + 1 (readyfordeparture m nil nil time)))) + (id2 (v-ids + (mv-nth + 1 + (scheduling + (routing + (mv-nth + 1 + (readyfordeparture m nil nil time)) + (nodesetgenerator params)) + (nodesetgenerator params) + ntkstate order))))) + (:instance tmissivesp-ready-4-departure-mv-1 + (nodeset (nodesetgenerator params))) + (:instance ToMissives-extract-sublst + (L (extract-sublst + m + (tm-ids + (mv-nth 1 + (readyfordeparture m nil nil time))))) + (ids (v-ids + (mv-nth + 1 + (scheduling + (routing + (mv-nth + 1 (readyfordeparture m nil nil time)) + (nodesetgenerator params)) + (nodesetgenerator params) + ntkstate order)))) + (nodeset (nodesetgenerator params))) + (:instance ids-routing + (M (mv-nth 1 (readyfordeparture m nil nil time)))) + (:instance tmissivesp-equal-subsetp + (x (mv-nth 1 (readyfordeparture m nil nil time))) + (nodeset (nodesetgenerator params)) + (y m)) + (:instance subsetp-arrived-newtrlst-ids + (trlst (routing + (mv-nth + 1 (readyfordeparture m nil nil + time)) + (nodesetgenerator params))) + (nodeset (nodesetgenerator params))))))) + + +(defthm subset-arrived-tm-ids-M + (implies (and (tmissivesp M (nodesetgenerator params)) + (validparamsp params)) + (subsetp (V-ids (mv-nth + 1 + (scheduling + (routing (mv-nth + 1 + (readyfordeparture m nil nil time)) + (nodesetgenerator params)) + (nodesetgenerator params) ntkstate order))) + (Tm-ids M))) + :hints (("Goal" + :in-theory (disable tmissivesp) + :use + ((:instance subset-ready-for-departure-2 + (nodeset (nodesetgenerator params))) + (:instance tmissivesp-ready-4-departure-mv-1 + (nodeset (nodesetgenerator params))) + (:instance ids-routing + (M (mv-nth 1 (readyfordeparture m nil nil time)))) + (:instance subsetp-arrived-newtrlst-ids + (trlst (routing + (mv-nth + 1 + (readyfordeparture m nil nil time)) + (nodesetgenerator params))) + (nodeset (nodesetgenerator params))))))) + + +(defthm lasttheorem-lemma1211 + (let ((nodeset (nodesetgenerator params)) + (mv1-sched + (mv-nth + 1 + (scheduling + (routing (mv-nth 1 (readyfordeparture m nil nil time)) + (nodesetgenerator params)) + (nodesetgenerator params) ntkstate order)))) + (implies (and (tmissivesp M nodeset) + (validparamsp params)) + (equal (extract-sublst (tomissives m) + (v-ids mv1-sched)) + (tomissives (extract-sublst + (mv-nth 1 (readyfordeparture m nil nil time)) + (v-ids mv1-sched)))))) + :hints (("Goal" + :in-theory (disable tmissivesp) + :use ((:instance lemma121final) + (:instance takingtomissivesout-equal))))) +(defthm true-listp-r4d + (implies (tmissivesp m nodeset) + (true-listp (mv-nth 0 (readyfordeparture m nil nil time)))) + :hints (("Goal" :use (tmissivesp-ready-4-departure-mv-0) + :in-theory (disable tmissivesp-ready-4-departure-mv-0))) + :rule-classes :type-prescription) + +(defthm genoc_t-thm ;; ok + ;; now we can prove the correctness of genoc_t + (let ((nodeset (nodesetgenerator params))) + (implies (and (tmissivesp m nodeset) ;(goodorder order) + (validparamsp params)) + (mv-let (cplt abt) + (genoc_t m nodeset measure nil accup time ntkstate order) + (declare (ignore abt)) + (genoc_t-correctness cplt m)))) + :otf-flg t + :hints (("goal" + :induct (genoc_t-non-tail-comp m (nodesetgenerator params) + measure time ntkstate order) + :do-not '(eliminate-destructors generalize) + :in-theory (disable trlstp tmissivesp lemma121final) + :do-not-induct t) + ("subgoal *1/2" + :in-theory (disable tmissivesp mv-nth + extract-sublst-cancel-m + lemma121final trlstp tmissivesp + lemma12) + :use + ((:instance gc1_arrived/rtg + (m (mv-nth 1 (readyfordeparture m nil nil time)))) + (:instance lasttheorem-lemma1211) + (:instance v-ids-genoc_t-non-tail-comp + (m (append (mv-nth + 0 + (scheduling + (routing + (mv-nth + 1 + (readyfordeparture m nil nil + time)) + (nodesetgenerator params)) + (nodesetgenerator params) + ntkstate order)) + (mv-nth + 0 (readyfordeparture m nil nil time)))) + (measure (mv-nth + 2 + (scheduling + (routing + (mv-nth + 1 + (readyfordeparture m nil nil time)) + (nodesetgenerator params)) + (nodesetgenerator params) + ntkstate order))) + (time (+ 1 time)) + (ntkstate (mv-nth + 3 + (scheduling + (routing + (mv-nth + 1 + (readyfordeparture m nil nil + time)) + (nodesetgenerator params)) + (nodesetgenerator params) + ntkstate order))) + (order (get_next_priority order))) + (:instance gc1_arrived/rtg + (m (mv-nth 1 (readyfordeparture m nil nil time)))))) + ("subgoal *1/2.2" + :use + ((:instance v-ids-genoc_t-non-tail-comp + (m (append + (mv-nth + 0 + (scheduling + (routing + (mv-nth + 1 (readyfordeparture m nil nil time)) + (nodesetgenerator params)) + (nodesetgenerator params) ntkstate + order)) + (mv-nth 0 (readyfordeparture m nil nil time)))) + (measure (mv-nth + 2 + (scheduling + (routing + (mv-nth 1 (readyfordeparture m nil nil + time)) + (nodesetgenerator params)) + (nodesetgenerator params) ntkstate + order))) + (time (+ 1 time)) + (ntkstate (mv-nth + 3 + (scheduling + (routing + (mv-nth + 1 (readyfordeparture m nil nil + time)) + (nodesetgenerator params)) + (nodesetgenerator params) + ntkstate order))) + (order (get_next_priority order))))) + ("Subgoal *1/3.1" + :in-theory (disable tmissivesp mv-nth + extract-sublst-cancel-m + lasttheorem-lemma1211 lemma12) + :use + ((:instance tmissivesp-ready-4-departure-mv-1 + (nodeset (nodesetgenerator Params))) + (:instance gc1_arrived/rtg + (M (mv-nth 1 (readyfordeparture m nil nil time)))))) + ("Subgoal *1/3.1'" + :in-theory (disable tmissivesp mv-nth + extract-sublst-cancel-m + lemma121final lemma12))))#|ACL2s-ToDo-Line|# + + + +;;------------------------------------------------------------ +;; definition and validation of genoc +;;------------------------------------------------------------ + +;; we load the generic definitions of the interfaces +(include-book "interfaces-computes") + +;(include-book "GeNoC-interfaces") + +;; ComputetTMissives +;; -------------- +;(defun computeTMissives (transactions) + ;; apply the function p2psend to build a list of tmissives + ;; from a list of transactions +;(if (endp transactions) +; nil +; (let* ((trans (car transactions)) +; (id (idt trans)) +; (org (orgt trans)) +; (msg (msgt trans)) +; (dest (destt trans)) +; (flit (flitt trans)) +; (time (timet trans))) +; (cons (list id org org (p2psend msg) dest flit time) +; (computetmissives (cdr transactions)))))) + + +;; ComputeResults +;; ------------- +;(defun computeresults (trlst) + ;; apply the function p2precv to build a list of results + ;; from a list of travels +; (if (endp trlst) +; nil +; (let* ((tr (car trlst)) +; (id (idv tr)) +; (r (car (routesv tr))) +; (dest (car (last r))) +; (frm (frmv tr)) +; (flit (flitv tr))) +; (cons (list id dest (p2precv frm) flit) +; (computeresults (cdr trlst)))))) + + +;; genoc +;; ----- + +(defun genoc (trs params params2 order) + ;; main function + (if (ValidStateParamsp params params2) + (mv-let (responses aborted simu) + (genoc_t (computetmissives trs) + (NodesetGenerator params) + (initial-measure (routing (computetmissives trs) (NodesetGenerator params)) + (NodesetGenerator params) + (generate-initial-ntkstate trs (stategenerator params params2)) + order) + nil + nil + '0 + (generate-initial-ntkstate trs (stategenerator params params2)) + order) + (declare(ignore simu)) + (mv (computeresults responses) aborted)) + (mv nil nil))) + +;; genoc correctness +;; ----------------- +(defun genoc-correctness (results trs/ids) + ;; trs/ids is the initial list of transactions filtered according + ;; to the ids of the list of results. + ;; we check that the messages and the destinations of these two lists + ;; are equal. + (and (equal (r-msgs results) + (t-msgs trs/ids)) + (equal (r-dests results) + (t-dests trs/ids)))) + +(defun all-frms-equal-to-p2psend (trlst trs) + ;; check that every frame of trlst is equal to the application + ;; of p2psend to the corresponding message in the list of + ;; transactions trs + (if (endp trlst) + (if (endp trs) + t + nil) + (let* ((tr (car trlst)) + (trans (car trs)) + (tr-frm (frmv tr)) + (t-msg (msgt trans))) + (and (equal tr-frm (p2psend2 t-msg)) + (all-frms-equal-to-p2psend (cdr trlst) (cdr trs)))))) + +(defthm gc1-=>-all-frms-equal-to-p2psend ;; ok + (implies (genoc_t-correctness1 trlst (tomissives (computetmissives trs))) + (all-frms-equal-to-p2psend trlst trs)) + :hints (("Goal" + :in-theory (disable last true-listp leq-position-equal-len + nfix len)))) + +(defthm all-frms-equal-r-msgs-t-msgs + ;; if frames have been computed by p2psend then + ;; computeresults applies p2precv. we get thus the initial msg. + (implies (and (all-frms-equal-to-p2psend trlst trs) + (validfields-trlst trlst nodeset)) + (equal (r-msgs (computeresults trlst)) + (t-msgs trs))) + :hints (("Goal" + :in-theory (disable last true-listp leq-position-equal-len + nfix len)))) + +(defthm gc1-r-dest-tm-dests ;; ok + (implies (and (genoc_t-correctness1 trlst m/trlst) + (validfields-trlst trlst nodeset) + (missivesp m/trlst nodeset)) + (equal (r-dests (computeresults trlst)) + (m-dests m/trlst)))) + + +(in-theory (disable mv-nth)) + +(defthm validfields-trlst-genoc_nt ;; ok + ;; to use the lemma all-frms-equal-to-p2psend we need to establish + ;; that genoc_nt contains travels with validfields + ;; and that it contains no duplicated ids + (let ((nodeset (nodesetgenerator params))) + (implies (and (tmissivesp m nodeset) + (validparamsp params)) + (validfields-trlst + (genoc_t-non-tail-comp m nodeset measure time ntkstate + order) + nodeset))) + :otf-flg t + :hints (("goal" + :do-not-induct t + :induct (genoc_t-non-tail-comp m (nodesetgenerator params) + measure time ntkstate order)) + ("subgoal *1/3" + :use + ((:instance tmissivesp-newTrlst + (trlst (routing + (mv-nth 1 (readyfordeparture m nil nil time)) + (nodesetgenerator params))) + (nodeset (nodesetgenerator params))) + (:instance trlstp-arrived + (trlst (routing + (mv-nth 1 (readyfordeparture m nil nil time)) + (nodesetgenerator params))) + (nodeset (nodesetgenerator params))) + (:instance tmissivesp-mv-nth-0-scheduling + (trlst (routing + (mv-nth 1 (readyfordeparture m nil nil time)) + (nodesetgenerator params))))) + :in-theory (disable tmissivesp-newTrlst trlstp-arrived + tmissivesp-mv-nth-0-scheduling)))) + + +(defthm tm-orgs-computetmissives ;; ok + (equal (tm-orgs (computetmissives trs)) + (t-orgs trs))) + +(defthm tm-dests-computetmissives ;; ok + (equal (tm-dests (computetmissives trs)) + (t-dests trs))) + + + +(defthm tm-ids-computestmissives ;; ok + ;; lemma for the next defthm + (equal (tm-ids (computetmissives trs)) + (t-ids trs))) + + +(defthm tmissivesp-computetmissives ;; ok + (implies (transactionsp trs nodeset) + (tmissivesp (computetmissives trs) nodeset))) + + + +(defthm Extract-computemissives-tmissivesp-instance + (implies (and (transactionsp trs (nodesetgenerator params)) + (validparamsp params)) + (tmissivesp + (extract-sublst (computetmissives trs) + (v-ids + (genoc_t-non-tail-comp (computetmissives trs) + (nodesetgenerator params) + measure time ntkstate order))) + (nodesetgenerator params))) + :hints (("Goal" + :use + ((:instance v-ids-genoc_t-non-tail-comp + (m (computetmissives trs))) + (:instance tmissivesp-computetmissives + (nodeset (nodesetgenerator params))) + (:instance subset-arrived-tm-ids-M + (M (computetmissives trs))) + (:instance v-ids-genoc_t-non-tail-comp-no-dup + (M (computetmissives trs))))))) + + +(defthm computetmissives-assoc-equal ;; ok + ;; if (assoc-equal e l) is not nil then we can link + ;; assoc-equal and computetmissives as follows: + ;; (this lemma is needed to prove the next defthm) + (implies (assoc-equal e l) + (equal (computetmissives (list (assoc-equal e l))) + (list (assoc-equal e (computetmissives l)))))) + + +(defthm computetmissives-append ;; ok + (equal (computetmissives (append a b)) + (append (computetmissives a) + (computetmissives b)))) + + +(defthm member-equal-assoc-equal-not-nil-t-ids + ;; if e is an id of a travel of l + ;; then (assoc-equal e l) is not nil + (implies (and (member-equal e (t-ids trs)) + (validfields-t trs)) + (assoc-equal e trs))) + +(defthm computetmissives-extract-sublst ;; ok + ;; calls of computetmissives are moved into calls + ;; of extract-sublst + (implies (and (subsetp ids (t-ids trs)) + (validfields-t trs)) + (equal (computetmissives (extract-sublst trs ids)) + (extract-sublst (computetmissives trs) ids))) + :otf-flg t + :hints (("goal" + :induct (extract-sublst trs ids) + :do-not-induct t + :in-theory (disable computetmissives append)))) + + +(defthm computemissives-Extract-tmissivesp-instance + (implies (and (transactionsp trs (nodesetgenerator params)) + (validparamsp params)) + (tmissivesp + (computetmissives + (extract-sublst trs + (v-ids + (genoc_t-non-tail-comp (computetmissives trs) + (nodesetgenerator params) + measure time + ntkstate + order)))) + (nodesetgenerator params))) + + :hints (("Goal" + :use + ((:instance v-ids-genoc_t-non-tail-comp + (m (computetmissives trs))) + (:instance Extract-computemissives-tmissivesp-instance) + (:instance subset-arrived-tm-ids-M + (M (computetmissives trs))) + (:instance v-ids-genoc_t-non-tail-comp-no-dup + (M (computetmissives trs))) + (:instance computetmissives-extract-sublst + (ids (v-ids + (genoc_t-non-tail-comp (computetmissives trs) + (nodesetgenerator params) + measure time ntkstate + order)))))))) + + + +(in-theory (disable fwd-chaining-transactionsp)) + +(defthm gc1-gnc-trs + (implies (and (transactionsp trs (nodesetgenerator params)) + (validparamsp params)) + (genoc_t-correctness1 + (genoc_t-non-tail-comp + (computetmissives trs) + (nodesetgenerator params) measure '0 ntkstate order) + (tomissives (computetmissives + (extract-sublst + trs + (v-ids + (genoc_t-non-tail-comp + (computetmissives trs) (nodesetgenerator params) + measure '0 ntkstate order))))))) + :hints (("Goal" :use ((:instance v-ids-genoc_t-non-tail-comp + (time '0) + (m (computetmissives trs))) + (:instance tomissives-extract-sublst + (l (computetmissives trs)) + (ids (v-ids + (genoc_t-non-tail-comp + (computetmissives trs) + (nodesetgenerator params) + measure + '0 ntkstate order))) + (nodeset (nodesetgenerator params))) + (:instance genoc_t-thm + (time '0) + (m (computetmissives trs))))))) + + +(defthm gc1-=>-all-frms-equal-to-p2psend-instance ;; ok + (implies (and (transactionsp trs (nodesetgenerator params)) + (validparamsp params)) + (all-frms-equal-to-p2psend + (genoc_t-non-tail-comp (computetmissives trs) + (nodesetgenerator params) + measure '0 ntkstate order) + (extract-sublst trs + (v-ids + (genoc_t-non-tail-comp + (computetmissives trs) (nodesetgenerator params) + measure '0 ntkstate order)))))) + +(defthm gc1-gnc-trs-inv + (implies (and (transactionsp Trs (nodesetgenerator params)) + (validparamsp params)) + (genoc_t-correctness1 + (genoc_t-non-tail-comp (computetmissives + trs)(nodesetgenerator params) measure + '0 ntkstate order) + (tomissives + (extract-sublst (computetmissives trs) + (v-ids + (genoc_t-non-tail-comp + (computetmissives trs) + (nodesetgenerator params) + measure '0 ntkstate order)))))) + :hints (("Goal" + :in-theory (disable transactionsp) + :use + ((:instance v-ids-genoc_t-non-tail-comp + (time '0) + (m (computetmissives trs))) + (:instance subset-arrived-tm-ids-M + (time '0) + (M (computetmissives trs))) + (:instance v-ids-genoc_t-non-tail-comp-no-dup + (time '0) + (M (computetmissives trs))) + (:instance tmissivesp-computetmissives + (nodeset (nodesetgenerator params))) + (:instance computetmissives-extract-sublst + (ids (v-ids (genoc_t-non-tail-comp + (computetmissives trs) + (nodesetgenerator params) + measure '0 ntkstate order)))) + (:instance gc1-gnc-trs))))) + + +(defthm all-frms-equal-r-msgs-t-msgs-instance + ;; if frames have been computed by p2psend then + ;; computeresults applies p2precv. we get thus the initial msg. + (implies (and (transactionsp trs (nodesetgenerator params)) + (validparamsp params)) + (equal (r-msgs (computeresults + (genoc_t-non-tail-comp + (computetmissives trs)(nodesetgenerator + params) + measure '0 ntkstate order))) + (t-msgs (extract-sublst + trs + (v-ids + (genoc_t-non-tail-comp + (computetmissives trs) (nodesetgenerator params) + measure '0 ntkstate order)))))) + :hints (("Goal" + :use + ((:instance validfields-trlst-genoc_nt + (time '0) + (m (computetmissives trs))) + (:instance all-frms-equal-r-msgs-t-msgs + (nodeset (nodesetgenerator params)) + (trlst (genoc_t-non-tail-comp + (computetmissives trs) + (nodesetgenerator params) measure '0 + ntkstate order)) + (trs (extract-sublst + trs + (v-ids (genoc_t-non-tail-comp + (computetmissives trs) + (nodesetgenerator params) + measure '0 ntkstate order))))))))) + +(defthm r-ids-computeresults + (equal (r-ids (computeresults x)) + (v-ids x))) + +(defthm all-frms-equal-r-msgs-t-msgs-instance-use + ;; if frames have been computed by p2psend then + ;; computeresults applies p2precv. we get thus the initial msg. + (implies (and (transactionsp trs (nodesetgenerator params)) + (validparamsp params)) + (equal (r-msgs + (computeresults + (genoc_t-non-tail-comp (computetmissives trs) + (nodesetgenerator params) + measure '0 ntkstate order))) + (t-msgs (extract-sublst + trs + (r-ids(computeresults + (genoc_t-non-tail-comp + (computetmissives trs) + (nodesetgenerator params) + measure '0 ntkstate order)))))))) + + +(defthm gc1-r-dest-tm-dests-inst ;; ok + (implies (and (and (transactionsp trs (nodesetgenerator params)) + (validparamsp params))) + (equal (r-dests + (computeresults + (genoc_t-non-tail-comp (computetmissives trs) + (nodesetgenerator params) + measure '0 ntkstate order))) + (m-dests (tomissives + (extract-sublst (computetmissives trs) + (v-ids + (genoc_t-non-tail-comp + (computetmissives trs) + (nodesetgenerator params) + measure '0 ntkstate order))))))) + :hints (("Goal" :in-theory (disable len nfix nth) + :use + ((:instance gc1-gnc-trs) + (:instance gc1-r-dest-tm-dests) + (:instance validfields-trlst-genoc_nt + (time '0) + (m (computetmissives trs))) + (:instance to-missives-missivesp + (m (extract-sublst + (computetmissives trs) + (v-ids + (genoc_t-non-tail-comp + (computetmissives trs) + (nodesetgenerator params)measure + '0 ntkstate order)))) + (nodeset (nodesetgenerator params) ) ) + (:instance tmissivesp-computetmissives + (nodeset (nodesetgenerator params))) + (:instance v-ids-genoc_t-non-tail-comp + (time '0) + (m (computetmissives trs))) + (:instance subset-arrived-tm-ids-M + (time '0) + (M (computetmissives trs))) + (:instance v-ids-genoc_t-non-tail-comp-no-dup + (time '0) + (M (computetmissives trs))) + (:instance computetmissives-extract-sublst + (ids (v-ids + (genoc_t-non-tail-comp + (computetmissives trs) + (nodesetgenerator params) + measure '0 ntkstate order)))) + (:instance tm-ids-computestmissives ) + (:instance gc1-r-dest-tm-dests + (nodeset (nodesetgenerator params)) + (trlst (genoc_t-non-tail-comp + (computetmissives trs) + (nodesetgenerator params) + measure '0 ntkstate order)) + (m/trlst (tomissives + (extract-sublst + (computetmissives trs) + (v-ids (genoc_t-non-tail-comp + (computetmissives trs) + (nodesetgenerator params) + measure '0 ntkstate order)))))))))) + +(defthm gc1-r-dest-tm-dests-inst-use ;; ok + (implies (and (and (transactionsp trs (nodesetgenerator params)) + (validparamsp params))) + (equal (r-dests + (computeresults + (genoc_t-non-tail-comp + (computetmissives trs) + (nodesetgenerator params) measure '0 ntkstate order))) + (m-dests + (tomissives + (extract-sublst + (computetmissives trs) + (r-ids (computeresults + (genoc_t-non-tail-comp + (computetmissives trs) + (nodesetgenerator params) + measure '0 ntkstate order))))))))) + +(defthm m-dest-t-dests-extract-sublst ;; ok + (implies (and (subsetp ids (t-ids trs)) + (validfields-t trs)) + (equal (tm-dests (extract-sublst (computetmissives trs) ids)) + (t-dests (extract-sublst trs ids)))) + :hints (("goal" + :do-not-induct t + :use (:instance tm-dests-computetmissives + (trs (extract-sublst trs ids))) + :in-theory (disable tm-dests-computetmissives)))) + + + +(defthm tm-dests-compute-missives-extract-sublst-use + (implies (and (subsetp ids (t-ids trs)) + (transactionsp trs nodeset)) + (equal (t-dests (extract-sublst trs ids)) + (tm-dests (extract-sublst (computetmissives trs) ids)))) + :rule-classes nil) + +(defthm m-dests-tm-dests + (equal (m-dests (tomissives x)) + (tm-dests x))) + +(defthm m-dests-to-missives-compute-missives-extract-sublst-use + (implies (and (subsetp ids (t-ids trs)) + (transactionsp trs nodeset)) + (equal (t-dests (extract-sublst trs ids)) + (m-dests (tomissives (extract-sublst + (computetmissives trs) + ids))))) + :rule-classes nil) + +(defthm m-dests-to-missives-compute-missives-extract-sublst-use-instance + (implies (and (transactionsp trs (nodesetgenerator params)) + (validparamsp params)) + (equal (t-dests + (extract-sublst + trs + (r-ids + (computeresults + (genoc_t-non-tail-comp (computetmissives trs) + (nodesetgenerator params) + measure '0 ntkstate order))))) + (m-dests + (tomissives (extract-sublst + (computetmissives trs) + (r-ids + (computeresults + (genoc_t-non-tail-comp + (computetmissives trs) + (nodesetgenerator params) + measure '0 ntkstate order)))))))) + :hints (("Goal" + :use + ((:instance m-dests-to-missives-compute-missives-extract-sublst-use + (nodeset (nodesetgenerator params)) + (ids (r-ids + (computeresults + (genoc_t-non-tail-comp (computetmissives trs) + (nodesetgenerator params) + measure '0 ntkstate order))))) + (:instance tmissivesp-computetmissives + (nodeset (nodesetgenerator params))) + (:instance v-ids-genoc_t-non-tail-comp + (time '0) + (m (computetmissives trs))))))) + +(defthm equality-to-test + (let ((nodeset (nodesetgenerator params))) + (mv-let (results aborted) + (genoc trs params params2 order) + (declare (ignore aborted)) + (implies (and (transactionsp trs nodeset) + (validstateparamsp params params2)) + (equal + (computeresults + (genoc_t-non-tail-comp (computetmissives trs) + (nodesetgenerator + params) + (initial-measure (routing (computetmissives trs) (NodesetGenerator params)) + (NodesetGenerator params) + (generate-initial-ntkstate trs (stategenerator params params2)) + order) + '0 + (generate-initial-ntkstate trs (stategenerator params params2)) + order)) + results)))) + + :hints (("Goal" + :use + (:instance + m-dests-to-missives-compute-missives-extract-sublst-use-instance + (ntkstate (stategenerator params params2)))))) + + +(defthm genoc-is-correct ;; ok + (let ((nodeset (nodesetgenerator params))) + (mv-let (results aborted) + (genoc trs params params2 order) + (declare (ignore aborted)) + (implies (and (transactionsp trs nodeset) + (validstateparamsp params params2)) + (genoc-correctness + results + (extract-sublst trs (r-ids results)))))) + :otf-flg t + :hints (("goal" :do-not-induct t + :in-theory (disable equality-to-test len nfix nth) + :use + ((:instance all-frms-equal-r-msgs-t-msgs-instance-use ) + (:instance equality-to-test ) + (:instance + m-dests-to-missives-compute-missives-extract-sublst-use-instance + (ntkstate (generate-initial-ntkstate trs (stategenerator params params2))) + (measure (initial-measure (routing (computetmissives trs) (NodesetGenerator params)) + (NodesetGenerator params) + (generate-initial-ntkstate trs (stategenerator params params2)) + order)))))))
\ No newline at end of file diff --git a/books/workshops/2009/verbeek-schmaltz/verbeek/generic-modules/interfaces-computes.lisp b/books/workshops/2009/verbeek-schmaltz/verbeek/generic-modules/interfaces-computes.lisp new file mode 100644 index 0000000..e8b0f37 --- /dev/null +++ b/books/workshops/2009/verbeek-schmaltz/verbeek/generic-modules/interfaces-computes.lisp @@ -0,0 +1,133 @@ +#|$ACL2s-Preamble$; +;; Amr Helmy +;; instance of interfaces +;; October 26th 2007 +;; File: Interfaces-computes.lisp +;; Amr helmy +;; 31st october 2007 + +(begin-book);$ACL2s-Preamble$|# + + +(in-package "ACL2") +(include-book "GeNoC-misc") +(include-book "GeNoC-interfaces") +(defun p2psend2 (msg) msg) +(defun p2precv2 (frm) frm) + + + +;;|-----------------------------------------------------------------------| +;;| ComputeTmissives & Computeresults | +;;|-----------------------------------------------------------------------| + +(defun computetmissives (transactions) + ;; apply the function p2psend to build a list of tmissives + ;; from a list of transactions + (if (endp transactions) + nil + (let* ((trans (car transactions)) + (id (idt trans)) + (org (orgt trans)) + (msg (msgt trans)) + (dest (destt trans)) + (flit (flitt trans)) + (time (timet trans))) + (cons (list id org org (p2psend2 msg) dest flit time) + (computetmissives (cdr transactions)))))) + +(defthm tm-ids-computestmissives ;; ok + ;; lemma for the next defthm + (equal (tm-ids (computetmissives trs)) + (t-ids trs))) + +(defthm tm-dests-computetmissives ;; ok + (equal (tm-dests (computetmissives trs)) + (t-dests trs))) + +(defthm tm-orgs-computetmissives ;; ok + (equal (tm-orgs (computetmissives trs)) + (t-orgs trs))) + +(defthm tmissivesp-computetmissives ;; ok + (implies (transactionsp trs nodeset) + (tmissivesp (computetmissives trs) nodeset))) + +(defthm tmissivesp-computetmissives-extract-sublst + (implies (and (transactionsp trs nodeset) + (no-duplicatesp-equal ids) + (subsetp ids (tm-ids (computetmissives trs)))) + (tmissivesp (extract-sublst (computetmissives trs) ids) nodeset))) + +(defthm m-ids-computtmisives-tomissives ;;change name + (equal (m-ids (tomissives (computetmissives trs))) (t-ids trs))) + +(defthm m-dests-computtmisives-tomissives + (equal (m-dests (tomissives (computetmissives trs))) (t-dests trs))) + +;; the next four lemmas are similar to those used to prove +;; the lemma tomissives-extract-sublst .... (proof by analogy) + +(defthm computetmissives-append ;; ok + (equal (computetmissives (append a b)) + (append (computetmissives a) (computetmissives b)))) + +(defthm member-equal-assoc-equal-not-nil-t-ids + ;; if e is an id of a travel of l + ;; then (assoc-equal e l) is not nil + (implies (and (member-equal e (t-ids trs)) + (validfields-t trs)) + (assoc-equal e trs))) + +(defthm computetmissives-assoc-equal ;; ok + ;; if (assoc-equal e l) is not nil then we can link + ;; assoc-equal and computetmissives as follows: + ;; (this lemma is needed to prove the next defthm) + (implies (assoc-equal e l) + (equal (computetmissives (list (assoc-equal e l))) + (list (assoc-equal e (computetmissives l)))))) + +(defthm computetmissives-extract-sublst ;; ok + ;; calls of computetmissives are moved into calls + ;; of extract-sublst + (implies (and (subsetp ids (t-ids trs)) + (validfields-t trs)) + (equal (computetmissives (extract-sublst trs ids)) + (extract-sublst (computetmissives trs) ids))) + :otf-flg t + :hints (("goal" + :induct (extract-sublst trs ids) + :do-not-induct t + :in-theory (disable computetmissives append)))) + +(defthm m-dest-t-dests-extract-sublst-inst ;; ok + (implies (and (subsetp ids (t-ids trs)) + (validfields-t trs)) + (equal (tm-dests (extract-sublst (computetmissives trs) ids)) + (t-dests (extract-sublst trs ids)))) + :hints (("goal" + :do-not-induct t + :use (:instance tm-dests-computetmissives + (trs (extract-sublst trs ids))) + :in-theory (disable tm-dests-computetmissives)))) + + +;; computeresults +;; ------------- +(defun computeresults (trlst) + ;; apply the function p2precv to build a list of results + ;; from a list of travels + (if (endp trlst) + nil + (let* ((tr (car trlst)) + (id (idv tr)) + (r (car (routesv tr))) + (dest (car (last r))) + (frm (frmv tr)) + (flit (flitv tr))) + (cons (list id dest (p2precv2 frm) flit) + (computeresults (cdr trlst)))))) + +(defthm r-ids-computeresults + (equal (r-ids (computeresults x)) + (v-ids x)))
\ No newline at end of file diff --git a/books/workshops/2009/verbeek-schmaltz/verbeek/generic-modules/own-perm.lisp b/books/workshops/2009/verbeek-schmaltz/verbeek/generic-modules/own-perm.lisp new file mode 100644 index 0000000..62c6858 --- /dev/null +++ b/books/workshops/2009/verbeek-schmaltz/verbeek/generic-modules/own-perm.lisp @@ -0,0 +1,141 @@ +#|$ACL2s-Preamble$; +; ****************** BEGIN INITIALIZATION FOR ACL2s MODE ****************** ; +; (Nothing to see here! Your actual file is after this initialization code); + +#+acl2s-startup (er-progn (assign fmt-error-msg "Problem loading ACL2's lexicographic-ordering book.~%This indicates that either your ACL2 installation is missing the standard books are they are not properly certified.") (value :invisible)) +(include-book "ordinals/lexicographic-ordering" :dir :system) + +#+acl2s-startup (er-progn (assign fmt-error-msg "Problem loading the CCG book.~%Please choose \"Recertify ACL2s system books\" under the ACL2s menu and retry after successful recertification.") (value :invisible)) +(include-book + "ccg" :uncertified-okp nil :dir :acl2s-modes :ttags ((:ccg)) :load-compiled-file :comp) + +#+acl2s-startup (er-progn (assign fmt-error-msg "Problem loading ACL2s customizations book.~%Please choose \"Recertify ACL2s system books\" under the ACL2s menu and retry after successful recertification.") (value :invisible)) +(include-book + "custom" :dir :acl2s-modes :uncertified-okp nil :load-compiled-file :comp) + +#+acl2s-startup (er-progn (assign fmt-error-msg "Problem setting up ACL2s mode.") (value :invisible)) +; Other events: +(set-well-founded-relation l<) + +; Non-events: +(set-guard-checking :none) + +; ******************* END INITIALIZATION FOR ACL2s MODE ******************* ; +;$ACL2s-SMode$;ACL2s +;;Amr HELMY +;; this file is similar to the one in the ACL2 book library the +;; differences are +;; some extra theorems at the end. +;; and the main difference is the change in the permutation function +;; to use member-equal instead of the function in used in the books. +;; But apart from that it is the same as the one in the ACL2 distribution +;; own-perm.lisp +;; 13th March 2008 +(begin-book t :TTAGS ((:CCG)));$ACL2s-Preamble$|# + +(in-package "ACL2")#|ACL2s-ToDo-Line|# + + +(defun del (a x) + (cond ((atom x) nil) + ((equal a (car x)) (cdr x)) + (t (cons (car x) (del a (cdr x)))))) + +(defun is-perm (x y) + (cond ((atom x) (and (equal x y) (atom y))) + (t (and (member-equal (car x) y) + (is-perm (cdr x) (del (car x) y)))))) + +(local (defthm is-perm-reflexive + (is-perm x x))) + +(local + (encapsulate + () + + (local + (defthm is-perm-del + (implies (member-equal a y) + (equal (is-perm (del a y) x) + (is-perm y (cons a x)))) + :hints (("Goal" :induct (is-perm y x))))) + + (defthm is-perm-symmetric + (implies (is-perm x y) (is-perm y x))))) + + +(defthm member-del-member-normal + (implies (member-equal x1 (del (car y) z)) + (member-equal x1 z))) + + +(local (defthm is-perm-implies-same-in + (implies (and (not (member-equal x1 z)) + (member-equal x1 y)) + (not (is-perm y z))))) +(local (defthm del-del + (equal (del a (del b x)) + (del b (del a x))))) + +(defthm member-not-equal-member-equal + (implies (and (member-equal a z) (not (equal a b))) + (member-equal a (del b z)))) + +(local (defthm is-perm-del-del + (implies (and (member-equal a y) + (member-equal a z)) + (equal (is-perm y z) + (is-perm (del a y) (del a z)))))) + +(local (defthm is-perm-transitive + (implies (and (is-perm x y) (is-perm y z)) + (is-perm x z)) )) + +(defequiv is-perm) + + +;;this is the new addition to the file +;; the next theorem proves that if a is not a member of Z then it +;; won't be a member if we remove another member of Z +(defthm not-member-z-not-member-del + (implies (not (member-equal a z)) + (not (member-equal a (del b z))))) +;; If a is a member of Z and Z contains no duplications +;; then a is not member of (Z-a) +(defthm member-no-duplicatesp-not-member-del + (implies (and (member-equal a z) (no-duplicatesp-equal z)) + (not (member-equal a (del a z))))) +;; If y has no duplication removing an element from it keeps it +;; without duplications +(defthm no-duplicatesp-delete + (implies (no-duplicatesp-equal y) + (no-duplicatesp-equal (del a y)))) + +;; if x is a permutation of Z, and a is not a member of Z then A is +;; not a member of the tail of X +(defthm not-member-is-perm-no-member + (implies (and (not (member-equal a z)) (is-perm x z)) + (not (member-equal a (cdr x))))) +;; X is a permutation of Y, No duplications is Y then there is none in +;; X, and the first element of X is not member of its tail, needed of +;; the induction in the next theorem +(defthm is-perm-no-memberp + (implies (and (is-perm x y) (no-duplicatesp-equal y)) + (not (member-equal (car x) (cdr x)))) + :hints (("Subgoal *1/3.1" + :use (:instance not-member-is-perm-no-member + (a (car x)) (x (cdr x)) (z (DEL (CAR X) Y)))))) + +;; a list x is a permutation of Y, and no duplication in y +;; then x contains no duplications +(defthm is-perm-no-duplicatesp + (implies (and (is-perm x y) (no-duplicatesp-equal y)) + (no-duplicatesp-equal x)) + :hints (("subgoal *1/5''" + :use (:instance is-perm-no-memberp)) + ("subgoal *1/4" + :use (:instance no-duplicatesp-delete (a (car x)))))) + + + + diff --git a/books/workshops/2009/verbeek-schmaltz/verbeek/instantiations/departure/simple/simple-R4D.lisp b/books/workshops/2009/verbeek-schmaltz/verbeek/instantiations/departure/simple/simple-R4D.lisp new file mode 100644 index 0000000..5f53fdf --- /dev/null +++ b/books/workshops/2009/verbeek-schmaltz/verbeek/instantiations/departure/simple/simple-R4D.lisp @@ -0,0 +1,36 @@ +#|$ACL2s-Preamble$; +(begin-book);$ACL2s-Preamble$|# + +(in-package "ACL2") +(include-book "make-event/defspec" :dir :system) +(include-book "../../../generic-modules/GeNoC-departure") + +;----------------------------------------------------------------------- +; R4D: all missives are ready for departure +;----------------------------------------------------------------------- +(defun simple-readyfordeparture (missives delayed departing time) + (declare (ignore delayed departing time)) + (mv nil ; delayed missives + missives)); departing missives + +(defthm not-in-1-0-ready-for-dept-inst + (implies (tmissivesp m nodeset) + (not-in (tm-ids (mv-nth 1 (simple-readyfordeparture m nil nil time))) + (tm-ids (mv-nth 0 (simple-readyfordeparture m nil nil time)))))) + +(defthm not-in-1-0-ready-for-dept-inst-inverted + (implies (tmissivesp m nodeset) + (not-in (tm-ids (mv-nth 0 (simple-readyfordeparture m nil nil time))) + (tm-ids (mv-nth 1 (simple-readyfordeparture m nil nil time))))))#|ACL2s-ToDo-Line|# + + +;------------------------------------- +; the instantiations used in this file +;------------------------------------ +(defmacro inst-readyfordeparture (missives delayed departing time) + (list 'simple-readyfordeparture missives delayed departing time)) + + +(definstance GenericR4d R4D-simple + :functional-substitution + ((readyfordeparture simple-readyfordeparture)))
\ No newline at end of file diff --git a/books/workshops/2009/verbeek-schmaltz/verbeek/instantiations/genoc/simple-ct-global/sets.lisp b/books/workshops/2009/verbeek-schmaltz/verbeek/instantiations/genoc/simple-ct-global/sets.lisp new file mode 100644 index 0000000..90cae43 --- /dev/null +++ b/books/workshops/2009/verbeek-schmaltz/verbeek/instantiations/genoc/simple-ct-global/sets.lisp @@ -0,0 +1,77 @@ +#|$ACL2s-Preamble$; +(begin-book);$ACL2s-Preamble$|# + +(in-package "ACL2") + +(local (defun card (x) + (if (endp x) + 0 + (if (member-equal (car x) (cdr x)) + (card (cdr x)) + (nfix (1+ (card (cdr x)))))))) +(local (defun setp (x) + (if (endp x) + t + (and (not (member-equal (car x) (cdr x))) + (setp (cdr x)))))) +(local (defun set-recursion-scheme (x y) + (if (endp x) y + (set-recursion-scheme (remove (car x) x) + (remove (car x) y))))) + + + +(local (defthm member-remove-nonmember + (implies (not (member-equal a x)) + (not (member-equal a (remove b x)))))) +(local (defthm setp-remove + (implies (setp x) + (setp (remove a x))) + :rule-classes :type-prescription)) +(local (defthm member-remove-diff-member + (implies (and (not (equal a b)) + (member-equal a x)) + (member-equal a (remove b x))))) +(local (defthm subsetp-remove + (implies (subsetp x y) + (subsetp (remove a x) + (remove a y))) + :hints (("Subgoal *1/5" :use (:instance member-remove-diff-member (a (car x)) (b a) (x y)))))) +(local (defthm card-remove-nonmember + (implies (not (member-equal a x)) + (equal (card (remove a x)) + (card x))))) +(local (defthm card-remove-member + (implies (member-equal a x) + (equal (card (remove a x)) + (1- (card x)))))) +(local (defthmd subsetp-implies-member + (implies (and (consp x) + (subsetp x y)) + (member-equal (car x) y)))) +(local (defthm equal-cards-imply-same-members + (implies (and (equal (card x) (card y)) + (setp x) (setp y) + (subsetp x y) + (member-equal a y)) + (member-equal a x)) + :hints (("Goal" :induct (set-recursion-scheme x y)) + ("Subgoal *1/2" :use (:instance subsetp-implies-member))))) +(local (defthm card-subset + (implies (and (setp x) (setp y) + (subsetp x y)) + (<= (card x) (card y))) + :hints (("Subgoal *1/4" :use (:instance equal-cards-imply-same-members + (a (car x)) (x (cdr x))))))) +(local (defthm nodups-len=card + (implies (no-duplicatesp-equal x) + (equal (len x) (card x))))) +(local (defthm nodups-list=set + (implies (no-duplicatesp-equal x) + (setp x)) + :rule-classes :type-prescription)) +(defthm len-nodup-subset + (implies (and (no-duplicatesp-equal x) + (no-duplicatesp-equal y) + (subsetp x y)) + (<= (len x) (len y)))) diff --git a/books/workshops/2009/verbeek-schmaltz/verbeek/instantiations/genoc/simple-ct-global/simple.lisp b/books/workshops/2009/verbeek-schmaltz/verbeek/instantiations/genoc/simple-ct-global/simple.lisp new file mode 100644 index 0000000..c5b25c5 --- /dev/null +++ b/books/workshops/2009/verbeek-schmaltz/verbeek/instantiations/genoc/simple-ct-global/simple.lisp @@ -0,0 +1,1078 @@ +#|$ACL2s-Preamble$; +(begin-book);$ACL2s-Preamble$|# + +(in-package "ACL2") + +(include-book "make-event/defspec" :dir :system) +(include-book "../../routing/XY/XYRouting") +(include-book "../../departure/simple/simple-R4D") +(include-book "../../scheduling/circuit-switching-global/circuit") +(include-book "../../simulation/simple/simple") +(include-book "../../interfaces/dummy-interfaces/interfaces-computes") +(include-book "ordinals/lexicographic-ordering" :dir :system) +(include-book "../../../generic-modules/GeNoC") +(include-book "sets") + +;;----------------------------- +;; Defintion of GeNoC +;;----------------------------- + + +; Instantiation of GeNoC with a 2DMesh, XY Routing and packet scheduling, +; a simple network state (each node has a constant number of buffers) +; and simple R4D +(defun simple-genoc_t (missives nodeset measure trlst accup time ntkstate order) + ;; the composition of routing and scheduling is built by function genoc_t. + ;; it takes as arguments: + ;; missives: List of missives + ;; nodeset: NodeSet + ;; measure: The measure that is decreased by the scheduler + ;; trlst: Accumulator of arrived travels + ;; accup: Accumulator of networkstates for simulation + ;; time: Notion of time + ;; ntkstate: Network state + ;; order: Ordering + ;; it returns: + ;; - the arrived messages + ;; - the en route messages + ;; - the network state accumulator for simulation + + ;; the measure is set to the measure defined by the scheduler + (declare (xargs :measure (acl2-count measure) + :hints (("Goal" :use (:instance ct-measure-decreases + (trlst (xy-routing-top (mv-nth 1 (inst-readyfordeparture missives nil nil time)) nodeset))))))) + (if (endp missives) + ;; no more messsages to send + (mv trlst nil accup) + ;; else + (mv-let (delayed departing) + ;; call R4D to determine which missives are ready for departure + (inst-readyfordeparture missives nil nil time) + ;; determine set of routes for all departing missives + (let ((v (XY-routing-top departing nodeset))) + ;; check if it is possible to schedule + (cond ((not (inst-legal-measure measure v nodeset ntkstate order)) + ;; illegal measure supplied + (mv trlst missives accup)) + ((inst-scheduling-assumptions v nodeset ntkstate order) + ;; schedule and recursivily call genoc_t + (mv-let (newtrlst arrived newmeasure newntkstate) + (inst-scheduling v nodeset ntkstate order) + (simple-genoc_t (append newtrlst delayed) + nodeset + newmeasure + (append arrived trlst) + (append accup (list (simple-extract-simulation newntkstate))) + (+ 1 time) + newntkstate + (inst-get_next_priority order)))) + (t + ;; scheduler has instructed to terminate + (mv trlst missives accup))))))) + + +; talst List of transactions +; p1: Parameter for generating nodes, a coordinate (X Y) +; p2: Parameter for generating ntkstate, isn't used and can be anything +; order: Ordering. Isn't used, can be anything +(defun simple-genoc (talst p1 p2 order) + ;; main function + (if (simple-ValidStateParamsp p1 p2) + (mv-let (responses aborted accup) + (simple-genoc_t ;; compute traveling missives + (computetmissives talst) + ;; compute nodeset + (2DMesh-Nodesetgenerator p1) + ;; compute initial measure + (inst-initial-measure (xy-routing-top (computetmissives talst) (2DMesh-Nodesetgenerator p1)) + (2DMesh-Nodesetgenerator p1) + (inst-generate-initial-ntkstate talst (inst-StateGenerator p1 p2)) + order) + ;; accumulator for arrived travels + nil + ;; accumulator for simulation + nil + ;; time + '0 + ;; compute initial ntkstate + (inst-generate-initial-ntkstate talst (inst-StateGenerator p1 p2)) + order) + (declare (ignore accup)) + (mv (computeresults responses) aborted)) + (mv nil nil))) + +;; non-tail version of first value of genoc: the arrived messages +(defun simple-genoc_t-nt-mv-nth0 (missives nodeset measure time ntkstate order) + (declare (xargs :measure (acl2-count measure) + :hints (("Goal" :use (:instance ct-measure-decreases + (trlst (xy-routing-top (mv-nth 1 (inst-readyfordeparture missives nil nil time)) nodeset))))))) + (if (endp missives) + nil + (mv-let (delayed departing) + (inst-readyfordeparture missives nil nil time) + (let ((v (XY-routing-top departing nodeset))) + (cond ((not (inst-legal-measure measure v nodeset ntkstate order)) + nil) + ((inst-scheduling-assumptions v nodeset ntkstate order) + (mv-let (newtrlst arrived newmeasure newntkstate) + (ct-scheduling v nodeset ntkstate order) + (append + (simple-genoc_t-nt-mv-nth0 (append newtrlst delayed) + nodeset + newmeasure + (+ 1 time) + newntkstate + (inst-get_next_priority order)) + + arrived ))) + (t + nil)))))) +;; proof equality between tail and non-tailversion of GeNoC_t +(defthm simple-genoc_t-nt-mv-nth0=tail-mv-nth0 + (equal (mv-nth 0 (simple-genoc_t missives nodeset measure trlst accup time ntkstate order)) + (append (simple-genoc_t-nt-mv-nth0 missives nodeset measure time ntkstate order) + trlst)) + :hints (("Goal" :in-theory (disable xy-routing-top ct-scheduling)))) + +;; non-tail version of second value of genoc: the delayed messages +(defun simple-genoc_t-nt-mv-nth1 (missives nodeset measure time ntkstate order) + (declare (xargs :measure (acl2-count measure) + :hints (("Goal" :use (:instance ct-measure-decreases + (trlst (xy-routing-top (mv-nth 1 (inst-readyfordeparture missives nil nil time)) nodeset))))))) + (if (endp missives) + nil + (mv-let (delayed departing) + (inst-readyfordeparture missives nil nil time) + (let ((v (XY-routing-top departing nodeset))) + (cond ((not (inst-legal-measure measure v nodeset ntkstate order)) + missives) + ((inst-scheduling-assumptions v nodeset ntkstate order) + (mv-let (newtrlst arrived newmeasure newntkstate) + (ct-scheduling v nodeset ntkstate order) + (declare (ignore arrived)) + (simple-genoc_t-nt-mv-nth1 (append newtrlst delayed) + nodeset + newmeasure + (+ 1 time) + newntkstate + (inst-get_next_priority order)))) + (t + missives)))))) +;; proof equality between tail and non-tailversion of GeNoC_t +(defthm simple-genoc_t-nt-mv-nth1=tail-mv-nth1 + (equal (mv-nth 1 (simple-genoc_t missives nodeset measure trlst accup time ntkstate order)) + (simple-genoc_t-nt-mv-nth1 missives nodeset measure time ntkstate order)) + :hints (("Goal" :in-theory (disable xy-routing-top ct-scheduling)))) + + +;;---------------------------------------- +;; DEADLOCK FREEDOM FOR CIRCUIT SWITCHING +;;---------------------------------------- +;; The proof is structured as follows: +;; 1.) We define a property P which implies deadlockfreedom +;; 2.) We proof P implies a possible route +;; 3.) We prove P is preserved by GeNoC, i.e., if +;; it holds, then after one GeNoC-cycle it still holds. +;; 4.) We prove P implies en route is empty, by proving that +;; scheduling always provides a legal measure. +;; 5.) We prove that if en route is empty, then arrived is full. +;; +;; Property P is defined as: +;; (and ---the nodeset doesn't contain nil--- +;; (not (member-equal nil nodeset)) +;; ---each node has *num-of-buffers* buffers--- +;; (buffersize ntkstate *num-of-buffers*) +;; ---trlst has no travel whose frm is nil--- +;; (not (member-equal nil (V-Frms trlst))) +;; ---the trlst is created by xy routing--- +;; (trlst-created-by-xy-routing trlst nodeset) +;; ---trlst is a valid travel list--- +;; (trlstp trlst nodeset) +;; ---the nodeset is created by parameter p1--- +;; (p1-created-ntkstate p1 ntkstate)) +;; ---the network and trlst relate to each other--- +;; (n==t ntkstate trlst) +;; ---the situation is deadlockfree as defined below +;; (deadlockfree 0 trlst ntkstate) + + +;;---------------------------------------- +;; DEADLOCK FREEDOM FOR CIRCUIT SWITCHING +;; 1.) Definitions +;;---------------------------------------- + +;; 1.) Macro's used for convenience +(defmacro propertyP (trlst nodeset ntkstate p1) + `(and (not (member-equal nil ,nodeset)) + (buffersize ,ntkstate 3) + (not (member-equal nil (V-Frms ,trlst))) + (trlst-created-by-xy-routing ,trlst ,nodeset) + (trlstp trlst nodeset) + (p1-created-ntkstate ,p1 ,ntkstate) + (n==t ,ntkstate ,trlst) + (deadlockfree 0 ,trlst ,ntkstate))) +;; checks if the node is full in the current ntkstate +(defmacro full-node (node ntkstate) + (list 'not (list 'has-empty-buffer (list 'inst-readbuffers node ntkstate)))) +;; return t iff n is in the range of the length of the list l +(defmacro in-range (n l) + (list 'and (list 'natp n) (list '>= n 0) (list '< n (list 'len l)))) +;; hop1 denotes the first element of the first route +;; of the first travel of trlst +(defmacro hop1 (trlst) + (list 'caar (list 'RoutesV (list 'car trlst))))#|ACL2s-ToDo-Line|# + + + +;; 1.) Definition of ntkstate-trlst relation +;; we assume that the ntkstate and the trlst relate to each +;; other in the following way: if an entry is full, then +;; there exists a travel currently in that entry. This +;; is expressed by (ntkstate-trlst-relate ntkstate trlst) + +;; returns t iff there exists a travel v +;; in trlst with (FrmV v) = frm and +;; which is currently in entry +(defun frm-in-trlst (trlst frm node) + (if (endp trlst) + nil + (if (and (equal (FrmV (car trlst)) frm) + (equal (hop1 trlst) node)) + t + (frm-in-trlst (cdr trlst) frm node)))) +;; returns t iff each frame in the buffer is in +;; trlst +(defun buffercontents-in-trlst (buffer trlst node) + (if (endp buffer) + t + (if (or (equal (car buffer) nil) + (frm-in-trlst trlst (car buffer) node)) + (buffercontents-in-trlst (cdr buffer) trlst node) + nil))) +;; returns t if all the contents of the entries in ntkstate +;; are in a travel in trlst +(defun ntkstate-relates-to-trlst (ntkstate trlst) + (if (endp ntkstate) + t + (let* ((entry (car ntkstate)) + (buffer (get_buff entry))) + (if (and (consp entry) + (buffercontents-in-trlst buffer trlst (get_coor entry))) + (ntkstate-relates-to-trlst (cdr ntkstate) trlst) + nil)))) +;; the following function expresses the previopus relation +;; in a more convenient way: an ntkstate and trlst relate to +;; each other if updating the ntkstate with trlst +;; doesn't change the ntkstate +(defun n==t (ntkstate trlst) + (equal (update-ntkstate ntkstate trlst) ntkstate)) + + +;; 1.) Definition of trlst-created-by-xy-routing relation +;; we assume that the routes of trlst have been created by +;; the currently used routing function, i.e. xy. +;; This is expressed by the following function. +(defun trlst-created-by-xy-routing (trlst nodeset) + (equal (xy-routing-top (totmissives trlst) nodeset) trlst)) + + +;; 1.) Definition of buffer size of nodes +;; returns t if all entries of the ntkstate have +;; size number of buffers +(defun buffersize (ntkstate size) + (if (endp ntkstate) + t + (if (equal (len (get_buff (car ntkstate))) size) + (buffersize (cdr ntkstate) size) + nil))) + + +;; 1.) Defintion of p1-created-ntkstate +;; returns t iff the coordinates of the ntkstate are equal to the +;; nodeset generated by params +(defun p1-created-ntkstate (p1 ntkstate) + (and (2DMesh-validparamsp p1) + (equal (getcoordinates ntkstate) (2DMesh-NodesetGenerator p1)))) + + +;; 1.) Misc. definitions used in proof +;; returns t iff ntkstate1 is less or equal full +;; than ntkstate2 +(defun <=-full (ntkstate1 ntkstate2) + (if (endp ntkstate1) + t + (if (has-empty-buffer (car ntkstate2)) + (and (has-empty-buffer (car ntkstate1)) + (<=-full (cdr ntkstate1) (cdr ntkstate2))) + (<=-full (cdr ntkstate1) (cdr ntkstate2))))) +;; returns t if the list of buffers has at least +;; one full buffer +(defun E-full-buffer (buffer) + (cond ((endp buffer) nil) + ((car buffer) t) + (t (E-full-buffer (cdr buffer))))) +;; creates a list of all travels currently in a node +;; of the route +(defun get-travels-route (route trlst) + (if (endp route) + nil + (let ((recur (get-travels-route (cdr route) trlst))) + (append (get-travels (car route) trlst) + recur)))) +;; returns the number of elements in lst2 +;; that are not in lst1 +(defun diff-size (lst1 lst2) + (if (endp lst2) + 0 + (let ((recur (diff-size lst1 (cdr lst2)))) + (if (member-equal (car lst2) lst1) + recur + (nfix (1+ recur)))))) + +;; 1.) Definition of deadlockfree +;; theorems needed to prove termination of +;; the following function +(defthm subsetp-get-travels + (subsetp (get-travels org trlst) trlst)) +(defthm subsetp-get-travels-route + (subsetp (get-travels-route route trlst) trlst)) +(mutual-recursion + ;; deadlockfree_v returns nil if the given travel + ;; is or will be in deadlockstate and t otherwise. + ;; + ;; Parameters: + ;; v: the travel that is currently checked + ;; v-acc: an accumulator of travels already examined + ;; trlst: the complete initial trlst + ;; ntkstate: the network state + ;; + ;; A given travel v is deadlockfree if either + ;; 1.) each node of the route has empty buffers + ;; 2.) the travels that fill the nodes of the route are deadlockfree. + ;; If while checking the second condition v must again be checked, a cycle is encountered + ;; and thus v is in deadlockstate. Therefor the travels are accumulated in v-acc. + ;; + ;; From a computational point of view, this function can be much more effective. + ;; First, instead of checking al travels in a route with A-deadlockfree_v, it + ;; suffices to check if for all nodes in route there exists a travel that is deadlockfree. + ;; However, for such function E-deadlockfree_v, we can't prove the needed theorem + ;; subsetp-preverves-E-deadlockfree_v, because the witness can be outside the subset. + ;; Secondly, it is sufficient to check only full nodes, since a non-full node can't + ;; cause deadlock. This would increase complexity of the proof. + ;; Thirdly, the function could check, before it enters recursion, whether the rest of + ;; the route is free, and not go into recursion if so. Again this would increase + ;; complexity of the proof. + ;; + ;; The measure is a list of four elements, lexicographically compared: + ;; it is possible (but shouldn't occur) that v is not in the trlst. However this can occur + ;; only with the first call, since get-travels returns travels from trlst (see the previous + ;; theorem). The first element is 1 if v is not in trlst, and if so, decreases to 0 after the + ;; first call. The same holds for travels of A-deadlockfree_v. Thus for correct input the + ;; first element is always 0. + ;; The second element decreases on each call of A-deadlockfree_v in deadlockfree_v and remains + ;; equal on each call of deadlockfree_v in A-deadlockfree_v. + ;; The third element decreases on each call of deadlockfree_v in A-deadlockfree_v. + ;; The fourth element is the `self' decreasing measure: for deadlockfree_v this is constant + ;; since it's non-recursive. For A-deadlockfree_v this is the length of travels, since this + ;; decreases on each self-call. + (defun deadlockfree_v (v v-acc trlst ntkstate) + (declare (xargs :measure (list (if (member-equal v trlst) 0 1) (diff-size v-acc trlst) 0 0) + :well-founded-relation l<)) + (let* ((route (car (RoutesV v))) + (travels (get-travels-route (cdr route) trlst))) + (cond ((member-equal v v-acc) + ;; we get into a circle, the route isn't deadlockfree + nil) + ((has-empty-buffers (cdr route) ntkstate) + ;; the travel is possible, thus it is deadlockfree + t) + (t + (A-deadlockfree_v travels (cons v v-acc) trlst ntkstate))))) + ;; returns t iff all travels in travels + ;; are deadlockfree + (defun A-deadlockfree_v (travels v-acc trlst ntkstate) + (declare (xargs :measure (list (if (subsetp travels trlst) 0 1) (diff-size v-acc trlst) 1 (len travels)))) + (if (endp travels) + t + (and (deadlockfree_v (car travels) v-acc trlst ntkstate) + (A-deadlockfree_v (cdr travels) v-acc trlst ntkstate))))) + +;; deadlockfree returns t iff we can prove +;; deadlockfree_v for the last (len trlst) - n +;; travels in trlst. In case n = 0, it thus returns +;; t iff all travels are deadlockfree. +;; +;; We can't simply perform recursion on the trlst, +;; since we need to supply deadlockfree_v with the +;; complete trlst in each call. +(defun deadlockfree (n trlst ntkstate) + (declare (xargs :measure (nfix (- (len trlst) n)))) + (cond ((not (natp n)) + nil) + ((not (in-range n trlst)) + t) + (t + (and (deadlockfree_v (nth n trlst) nil trlst ntkstate) + (deadlockfree (1+ n) trlst ntkstate))))) + +;; some constants to test the function +;; creates a 3 by 3 mesh, filled as follows: +;; x x f +;; x x x +;; f x x +;; where x is a node with an empty buffer and +;; f a node with a full buffer. +;; For circuit and xy, this is deadlocked. +(defconst *dimension* '(3 3)) +(defconst *TransactionList* '((0 (0 0) "msg1" (2 0) 1 0) + (1 (0 0) "msg2" (2 0) 1 0) + (2 (0 0) "msg3" (2 0) 1 0) + (3 (2 0) "msg4" (0 0) 1 0) + (4 (2 0) "msg5" (0 0) 1 0) + (5 (2 0) "msg6" (0 0) 1 0))) +(defconst *Nodeset* (2DMesh-Nodesetgenerator *dimension*)) +(defconst *trlst* (xy-routing-top (computetmissives *Transactionlist*) *nodeset*)) +(defconst *ntkstate* (inst-generate-initial-ntkstate *Transactionlist* (inst-StateGenerator *dimension* nil))) +;(deadlockfree 0 *trlst* *ntkstate*) + +;; induction scheme that can be used to induct on deadlockfree_v +(defun deadlockfree_v-inductionscheme (flg v v-acc trlst ntkstate travels) + (declare (xargs :measure (list (if flg + (if (member-equal v trlst) 0 1) + (if (subsetp travels trlst) 0 1)) + (diff-size v-acc trlst) + (if flg 0 1) + (if flg 0 (len travels))) + :well-founded-relation l<)) + (if flg + (let* ((route (car (RoutesV v))) + (travels1 (get-travels-route (cdr route) trlst))) + (cond ((member-equal v v-acc) nil) + ((has-empty-buffers (cdr route) ntkstate) nil) + (t + (deadlockfree_v-inductionscheme nil v (cons v v-acc) trlst ntkstate travels1)))) + (cond ((endp travels) nil) + ((deadlockfree_v (car travels) v-acc trlst ntkstate) + (list (deadlockfree_v-inductionscheme t (car travels) v-acc trlst ntkstate travels) + (deadlockfree_v-inductionscheme nil v v-acc trlst ntkstate (cdr travels)))) + (t + nil)))) + + +;;---------------------------------------------------------- +;; THEOREM 2: deadlockfree implies that a route is possible +;;---------------------------------------------------------- + +;; update the ntkstate results in a ntkstate-trlst relation +(defthm buffercontents-cdr + (implies (buffercontents-in-trlst buffer (cdr trlst) node) + (buffercontents-in-trlst buffer trlst node))) +(defthm ntkstate-relates-updated-ntkstate + (implies (n==t ntkstate trlst) + (ntkstate-relates-to-trlst ntkstate trlst))) + +;; a route without full nodes implies that a route is possible +(defthm has-empty-buffers-implies-route-possible + (implies (and (trlstp trlst nodeset) + (has-empty-buffers (cdar (RoutesV v)) ntkstate) + (member-equal v trlst)) + (not (no-good-routes trlst ntkstate)))) +(defthm buffer-implies-travels + (implies (and (buffercontents-in-trlst buffer trlst node) + (E-full-buffer buffer)) + (consp (get-travels node trlst)))) +(defthm full-node-implies-travels + (implies (and (full-node node ntkstate) + (buffersize ntkstate 3) + (ntkstate-relates-to-trlst ntkstate trlst) + (member-equal node (getcoordinates ntkstate))) + (consp (get-travels node trlst))) + :hints (("Subgoal *1/2" + :use (:instance buffer-implies-travels (node (get_coor (car ntkstate))) + (buffer (get_buff (car ntkstate))))))) +(defthm non-empty-route-implies-travels-in-route + (implies (and (ntkstate-relates-to-trlst ntkstate trlst) + (buffersize ntkstate 3) + (subsetp route (getcoordinates ntkstate)) + (not (has-empty-buffers route ntkstate))) + (consp (get-travels-route route trlst))) + :hints (("Goal" :in-theory (disable has-empty-buffer)))) +;; thanks to this theorem, trlstp can be disabled in +;; the following proof +(defthm trlstp-implies-subsetp-route + (implies (and (trlstp trlst nodeset) + (member-equal v trlst)) + (subsetp (cdar (RoutesV v)) nodeset))) +;; use induction scheme to prove deadlockfree_v returns a route that is free +(defthm deadlockfree_v-implies-route-possible-flg + (if flg + (let ((v1 (deadlockfree_v v v-acc trlst ntkstate))) + (implies (and v1 + (buffersize ntkstate 3) + (ntkstate-relates-to-trlst ntkstate trlst) + (member-equal v trlst) + (trlstp trlst (getcoordinates ntkstate))) + (not (no-good-routes trlst ntkstate)))) + (let ((v1 (A-deadlockfree_v travels v-acc trlst ntkstate))) + (implies (and v1 + (buffersize ntkstate 3) + (ntkstate-relates-to-trlst ntkstate trlst) + (subsetp travels trlst) + (trlstp trlst (getcoordinates ntkstate)) + (consp travels)) + (not (no-good-routes trlst ntkstate))))) + :rule-classes nil + :hints (("Goal" :induct (deadlockfree_v-inductionscheme flg v v-acc trlst ntkstate travels) + :in-theory (disable trlstp routesv)))) +(defthm deadlockfree_v-implies-route-possible + (let ((v1 (deadlockfree_v v v-acc trlst ntkstate))) + (implies (and v1 + (buffersize ntkstate 3) + (ntkstate-relates-to-trlst ntkstate trlst) + (trlstp trlst (getcoordinates ntkstate)) + (member-equal v trlst)) + (not (no-good-routes trlst ntkstate)))) + :hints (("Goal" :use (:instance deadlockfree_v-implies-route-possible-flg (flg t))))) +;; first proof by induction that if the nth cdr +;; from trlst is deadlockfree then there is a possible route +(defthm nth-cdr-deadlockfree-implies-route-possible + (implies (and (consp trlst) + (buffersize ntkstate 3) + (ntkstate-relates-to-trlst ntkstate trlst) + (trlstp trlst (getcoordinates ntkstate)) + (deadlockfree n trlst ntkstate) + (in-range n trlst)) + (not (no-good-routes trlst ntkstate))) + :hints (("Subgoal *1/4" :use ((:instance deadlockfree_v-implies-route-possible + (v (nth n trlst)) (v-acc nil)))))) + +;; Theorem 2 is an instantiation of the previous theorem with n = 0 +;; All assumptions are part of property P +(defthm deadlockfree-implies-route-possible + (implies (and (consp trlst) + (buffersize ntkstate 3) + (n==t ntkstate trlst) + (trlstp trlst (getcoordinates ntkstate)) + (deadlockfree 0 trlst ntkstate)) + (not (no-good-routes trlst ntkstate))) + :hints (("Goal" :use (:instance nth-cdr-deadlockfree-implies-route-possible (n 0))))) + + +;;--------------------------------------------- +;; THEOREM 3: Property P is preserved by GeNoC +;;--------------------------------------------- +;; Proof: that (getcoordinates ntkstate) equals (getcoordinates newntkstate) +(defthm update-preserves-coor + (equal (getcoordinates (update-ntkstate ntkstate trlst)) + (getcoordinates ntkstate))) +(defthm scheduling-preserves-coor + (let* ((out (inst-scheduling trlst nodeset ntkstate order)) + (newntkstate (mv-nth 3 out))) + (equal (getcoordinates newntkstate) + (getcoordinates ntkstate)))) + +;; Proof: (buffersize ntkstate n) is preserved +(defthm update-preserves-buffersize + (implies (buffersize ntkstate *num-of-buffers*) + (buffersize (update-ntkstate ntkstate trlst) *num-of-buffers*))) +(defthm scheduling-preserves-buffersize + (let* ((out (inst-scheduling trlst nodeset ntkstate order)) + (newntkstate (mv-nth 3 out))) + (implies (buffersize ntkstate *num-of-buffers*) + (buffersize newntkstate *num-of-buffers*)))) + +;; Proof: (not (member-equal nil (v-frms trlst))) is preserved +(defthm scheduler-preserves-v-frms + (let ((newtrlst (ct-scheduler-nt-car trlst prev ntkstate))) + (implies (not (member-equal frm (V-Frms trlst))) + (not (member-equal frm (V-Frms newtrlst)))))) +(defthm routing-preserves-v-frms + (let ((newtrlst (xy-routing-top (totmissives trlst) nodeset))) + (implies (not (member-equal frm (V-Frms trlst))) + (not (member-equal frm (V-Frms newtrlst)))))) +(defthm mv-nth-equals-car + (implies (true-listp lst) + (equal (mv-nth 0 lst) + (car lst)))) +(defthm scheduling-preserves-v-frms + (let* ((out (inst-scheduling trlst nodeset ntkstate order)) + (newtrlst (xy-routing-top (car out) nodeset))) + (implies (not (member-equal frm (V-Frms trlst))) + (not (member-equal frm (V-Frms newtrlst)))))) + + +;; Proof: the routing remains the same for the delayed travels +;; Assume trlst is created by xy. If a.) newtrlst is a subset of trlst, +;; and b.) taking a subset preserves created-by-xy, +;; then newtrlst is created by xy as well. + +;; A.) +(defthm scheduled-is-subsetp + (let ((newtrlst (ct-scheduler-nt-car trlst prev ntkstate))) + (subsetp newtrlst trlst))) + +;; B.) +(defthm remove-twice-xyrouting + (equal (xyrouting (car (xyrouting current to)) + (car (last (xyrouting current to)))) + (xyrouting current to))) +(defthm remove-twice-xy-routing-top + (equal (xy-routing-top (totmissives (xy-routing-top missives nodeset)) nodeset) + (xy-routing-top missives nodeset))) +(defthm travel-from-xy-routing-list + (implies (and (member-equal (car newtrlst) trlst) + (trlst-created-by-xy-routing trlst nodeset)) + (equal (cons (list (caar newtrlst) (nth 1 (car newtrlst)) (nth 2 (car newtrlst)) + (list (xyrouting (caar (nth 3 (car newtrlst))) + (car (last (car (nth 3 (car newtrlst))))))) + (nth 4 (car newtrlst)) (nth 5 (car newtrlst))) + (cdr newtrlst)) + newtrlst))) +(defthm subsetp-preserves-created-by-xy + (implies (and (subsetp newtrlst trlst) + (true-listp newtrlst) + (trlst-created-by-xy-routing trlst nodeset)) + (trlst-created-by-xy-routing newtrlst nodeset)) + :hints (("Subgoal *1/1" :use (:instance travel-from-xy-routing-list)))) +;; Combing A.) and B.) +(defthm scheduler-preserves-created-by-xy + (let ((newtrlst (ct-scheduler-nt-car trlst nil ntkstate))) + (implies (trlst-created-by-xy-routing trlst nodeset) + (trlst-created-by-xy-routing newtrlst nodeset))) + :hints (("Goal" :use (:instance subsetp-preserves-created-by-xy (newtrlst (ct-scheduler-nt-car trlst nil ntkstate)))))) +(defthm created-by-xy-xy + (trlst-created-by-xy-routing (xy-routing-top trlst nodeset) nodeset)) + + +;; Proof: (trlstp trlst nodeset) is preserved +;; this is done using proof obligations +(defthm scheduling-preserves-trlstp + (let* ((nodeset (getcoordinates ntkstate)) + (out (inst-scheduling trlst nodeset ntkstate order)) + (newtrlst (car out))) + (implies (and (p1-created-ntkstate params ntkstate) + (trlstp trlst nodeset)) + (trlstp (xy-routing-top newtrlst nodeset) nodeset))) + :hints (("Goal" :in-theory (e/d (p1-created-ntkstate) + (totmissives trlstp 2DMesh-Nodesetgenerator xy-routing-top + 2dmesh-validparamsp totmissives))))) + + +;; Proof: (p1-created-ntkstate p1 ntkstate) is preserved +(defthm scheduling-preserves-nodeset-parameter + (let* ((nodeset (getcoordinates ntkstate)) + (out (inst-scheduling trlst nodeset ntkstate order)) + (newntkstate (mv-nth 3 out))) + (implies (p1-created-ntkstate p1 ntkstate) + (p1-created-ntkstate p1 newntkstate))) + :hints (("Goal" :in-theory (enable p1-created-ntkstate)))) + + +;; Proof: (n==t ntkstate trlst) is preserved +(defthm remove-twice-update-ntkstate + (implies (and (trlstp trlst2 nodeset) + (not (member-equal nil nodeset))) + (equal (update-ntkstate (update-ntkstate ntkstate trlst1) trlst2) + (update-ntkstate ntkstate trlst2)))) +(defthm genoc-preserves-n==t + (let* ((out (inst-scheduling trlst nodeset ntkstate order)) + (newntkstate (mv-nth 3 out)) + (newtrlst (xy-routing-top (car out) nodeset))) + (implies (and (trlstp trlst nodeset) + (not (member-equal nil nodeset)) + (trlst-created-by-xy-routing trlst nodeset) + (n==t ntkstate trlst)) + (n==t newntkstate newtrlst))) + :hints (("Goal" :in-theory (disable trlstp)) + ("Subgoal 1" :use ((:instance remove-twice-update-ntkstate + (trlst1 (ct-scheduler-nt-car TrLst nil ntkstate)) + (trlst2 (ct-scheduler-nt-car TrLst nil ntkstate))) + (:instance scheduler-preserves-created-by-xy))))) + + +;; Proof: (deadlockfree 0 ntrlst ntkstate) is preserved +;; We proof this theorem by first proving A.) it holds for an +;; abstraction of the ntkstate and trlst and then B.) that the +;; abstract properties hold for the output of the scheduler. +;; We abstract on the new ntkstate by using only +;; the property that it is 'less or equal full' than +;; the old one: +;; if an entry has an empty buffer then that is preserved. +;; We abstract on the new trlst by using only +;; the property that it is a subset of the old one. +;; This last abstraction holds for the global version +;; of circuit scheduling only. + +;; A.) the abstraction preserves deadlockfreedom +(defthm <=-full-preserves-has-empty-buffers + (implies (and (<=-full newntkstate ntkstate) + (equal (getcoordinates ntkstate) (getcoordinates newntkstate)) + (has-empty-buffers route ntkstate)) + (has-empty-buffers route newntkstate))) +;; the following theorem can only be proven if we now +;; for all travels that they are deadlockfree, instead +;; of that we merely know there exists a deadlockfree +;; travel +(defthm subsetp-preverves-A-deadlockfree_v + (implies (and (subsetp newtravels travels) + (A-deadlockfree_v travels v-acc trlst ntkstate)) + (A-deadlockfree_v newtravels v-acc trlst ntkstate))) +(defthm member-equal-get-travels + (implies (member-equal v trlst) + (member-equal v (get-travels (caar (RoutesV v)) trlst)))) +(defthm subsetp-trlst-get-travels + (implies (subsetp newtrlst trlst) + (subsetp (get-travels node newtrlst) (get-travels node trlst))) + :hints (("Subgoal *1/3" :in-theory (disable routesv)))) +(defthm subsetp-append-subsets + (implies (and (subsetp lst1 lst2) + (subsetp lst3 lst4)) + (subsetp (append lst1 lst3) (append lst2 lst4)))) +(defthm subsetp-trlst-get-travels-route + (implies (and (subsetp newtrlst trlst)) + (subsetp (get-travels-route route newtrlst) (get-travels-route route trlst)))) +;; use induction scheme to prove that deadlockfree_v is +;; preserved by the abstraction +(defthm abstraction-preserves-deadlockfree_v-flg + (implies (and (subsetp newtrlst trlst) + (equal (getcoordinates ntkstate) (getcoordinates newntkstate)) + (<=-full newntkstate ntkstate)) + (if flg + (implies (deadlockfree_v v v-acc trlst ntkstate) + (deadlockfree_v v v-acc newtrlst newntkstate)) + (implies (A-deadlockfree_v travels v-acc trlst ntkstate) + (A-deadlockfree_v travels v-acc newtrlst newntkstate)))) + :rule-classes nil + :hints (("Goal" :induct (deadlockfree_v-inductionscheme flg v v-acc trlst ntkstate travels)) + ("Subgoal *1/3" :use ((:instance subsetp-preverves-A-deadlockfree_v + (newtravels (get-travels-route (cdar (nth 3 v)) newtrlst)) + (travels (get-travels-route (cdar (nth 3 v)) trlst)) + (v-acc (cons v v-acc)) + (trlst newtrlst) + (ntkstate newntkstate)))))) +(defthm abstraction-preserves-deadlockfree_v + (implies (and (subsetp newtrlst trlst) + (equal (getcoordinates ntkstate) (getcoordinates newntkstate)) + (<=-full newntkstate ntkstate) + (deadlockfree_v v v-acc trlst ntkstate)) + (deadlockfree_v v v-acc newtrlst newntkstate)) + :hints (("Goal" :use (:instance abstraction-preserves-deadlockfree_v-flg (flg t))))) + +;; prove relation between deadlockfree_v and deadlockfree: +;; (deadlockfree 0 trlst ntkstate) +;; implies that for all travels deadlockfree_v +;; holds with the default parameters. +;; First prove it by induction on n, then +;; instantiate n with 0. +(defthm not-in-cdr-implies-equal-to-car + (implies (and (natp n) + (member-equal x (nthcdr n lst)) + (not (member-equal x (nthcdr (1+ n) lst)))) + (equal (nth n lst) x))) +(defthm member-equal-nth-element + (implies (and (in-range n lst1) + (subsetp lst1 lst2)) + (member-equal (nth n lst1) lst2))) +(defthm nth-cdr-deadlockfree-vs-deadlockfree_v + (implies (and (deadlockfree n trlst ntkstate) + (member-equal v (nthcdr n trlst))) + (deadlockfree_v v nil trlst ntkstate))) +(defthm deadlockfree-vs-deadlockfree_v + (implies (and (deadlockfree 0 trlst ntkstate) + (member-equal v trlst)) + (deadlockfree_v v nil trlst ntkstate)) + :hints (("Goal" :use (:instance nth-cdr-deadlockfree-vs-deadlockfree_v (n 0))))) +;; the abstract version of the theorem: +;; the abstraction preserves deadlockfree +;; up to the nth cdr of the new trlst +(defthm abstraction-preserves-deadlockfree-nth-cdr + (implies (and (subsetp newtrlst trlst) + (equal (getcoordinates ntkstate) (getcoordinates newntkstate)) + (<=-full newntkstate ntkstate) + (deadlockfree 0 trlst ntkstate) + (in-range n newtrlst)) + (deadlockfree n newtrlst newntkstate))) + + +;; B.) the scheduler output is a concrete version +;; of the abstraction +;; We already know that newtrlst is a subset of trlst. +;; Since newntkstate is obtained by updating ntkstate with +;; newtrlst, it suffices to proof that a ntkstate-update +;; with a smaller trlst results in a ntkstate that is lesser +;; or equal full. This holds only if the original ntkstate +;; relates to the original trlst, i.e. (n==t ntkstate trlst). +;; We use the book "sets" here. +(defthm frms-member-equal-nil-create-buffer + (implies (and (natp n) + (< (len travels) n)) + (member-equal nil (create-buffer n travels)))) +(defthm create-buffer-frms<n + (implies (and (not (member-equal nil (v-frms travels))) + (member-equal nil (create-buffer n travels)) + (natp n)) + (< (len travels) n))) +(defthm len-remove-dups + (implies (<= (len x) (len (remove-duplicates-equal y))) + (<= (len x) (len y)))) +(defthm subsetp-remove-dups + (implies (subsetp x y) + (subsetp x (remove-duplicates-equal y)))) +(defthm <-and-<=-imply-< + (implies (and (< x y) + (<= z x)) + (< z y))) +(defthm member-equal-nil-create-buffer + (implies (and (subsetp travels1 travels2) + (<= (len travels1) (len travels2)) + (no-duplicatesp travels1) + (natp n) + (not (member-equal nil (v-frms travels2))) + (member-equal nil (create-buffer n travels2))) + (member-equal nil (create-buffer n travels1))) + :hints (("Goal" :use (:instance <-and-<=-imply-< (x (len travels2)) (y n) (z (len travels1)))))) +(defthm get-travels-preserves-frms + (implies (not (member-equal frm (V-Frms trlst))) + (not (member-equal frm (V-Frms (get-travels node trlst)))))) +(defthm get-travels-preserves-not-member + (implies (not (member-equal v trlst)) + (not (member-equal v (get-travels node trlst))))) +(defthm get-travels-preserves-no-duplicatesp + (implies (no-duplicatesp-equal trlst) + (no-duplicatesp-equal (get-travels node trlst)))) +(defthm subsetp-newtrlst-implies-<=-full + (implies (and (not (member-equal nil (V-Frms trlst))) + (subsetp newtrlst trlst) + (no-duplicatesp newtrlst)) + (<=-full (update-ntkstate ntkstate newtrlst) + (update-ntkstate ntkstate trlst))) + :hints (("Subgoal *1/2" :use (:instance member-equal-nil-create-buffer + (travels1 (get-travels (cadaar ntkstate) newtrlst)) + (travels2 (get-travels (cadaar ntkstate) trlst)) + (n *num-of-buffers*))))) +(defthm no-duplicatesp-trlst + (implies (no-duplicatesp-equal (v-ids trlst)) + (no-duplicatesp-equal trlst)) + :hints (("Subgoal *1/2" :use (:instance member-equal-idv-v-ids + (v (car trlst)) (trlst (cdr trlst)))))) +(defthm scheduled-is-<=-full + (let* ((out (inst-scheduling trlst nodeset ntkstate order)) + (newntkstate (mv-nth 3 out))) + (implies (and (trlstp trlst nodeset) + (not (member-equal nil nodeset)) + (not (member-equal nil (V-Frms trlst))) + (n==t ntkstate trlst)) + (<=-full newntkstate ntkstate))) + :hints (("Subgoal 1" :use ((:instance subsetp-newtrlst-implies-<=-full + (newtrlst (ct-scheduler-nt-car TrLst nil ntkstate))))))) + + +;; A.) + B.) +;; Then prove an instantiation of the abstract theorem with n = 0 +;; and with newntkstate and newtrlst as provided by the scheduler +(defthm scheduler-preserves-deadlockfreedom + (let* ((out (inst-scheduling trlst nodeset ntkstate order)) + (newntkstate (mv-nth 3 out)) + (newtrlst (ct-scheduler-nt-car trlst prev ntkstate))) + (implies (and (trlstp trlst nodeset) + (not (member-equal nil nodeset)) + (not (member-equal nil (V-Frms trlst))) + (n==t ntkstate trlst) + (deadlockfree 0 trlst ntkstate)) + (deadlockfree 0 newtrlst newntkstate))) + :hints (("Goal" :use ((:instance abstraction-preserves-deadlockfree-nth-cdr + (newntkstate (mv-nth 3 (ct-scheduling trlst nodeset ntkstate order))) + (newtrlst (ct-scheduler-nt-car trlst prev ntkstate)) + (n 0))) + :in-theory (disable ct-scheduling n==t trlstp)))) + +;; Now that is has been proven that scheduler preserves dlf, +;; prove that new routing on the delayed travels preserves dlf. +(defthm genoc-preserves-deadlockfreedom + (let* ((nodeset (getcoordinates ntkstate)) + (out (inst-scheduling trlst nodeset ntkstate order)) + (newntkstate (mv-nth 3 out)) + (newtrlst (xy-routing-top (car out) nodeset))) + (implies (and (trlstp trlst nodeset) + (not (member-equal nil nodeset)) + (not (member-equal nil (V-Frms trlst))) + (n==t ntkstate trlst) + (trlst-created-by-xy-routing trlst nodeset) + (deadlockfree 0 trlst ntkstate)) + (deadlockfree 0 newtrlst newntkstate))) + :otf-flg t + :hints (("Goal" :in-theory (disable xy-routing-top ct-scheduling-assumptions ct-legal-measure + ct-test_routes trlstp scheduler-preserves-deadlockfreedom + scheduler-preserves-created-by-xy)) + ("Subgoal 2" :in-theory (e/d (trlst-created-by-xy-routing) + (scheduler-preserves-deadlockfreedom scheduler-preserves-created-by-xy)) + :use ((:instance scheduler-preserves-deadlockfreedom + (prev nil) (nodeset (getcoordinates ntkstate))) + (:instance scheduler-preserves-created-by-xy + (nodeset (getcoordinates ntkstate))))))) + + + +;;------------------------------------------------- +;; THEOREM 4: Property P implies en route is empty +;;------------------------------------------------- + +;; proof output of scheduler is legal measure +(defthm measure-is-routelengths + (equal (sum-of-lst (RouteLengths-TrLst (ct-scheduler-nt-car trlst prev ntkstate))) + (sum-of-lst (ct-scheduler-nt-mv2 TrLst prev ntkstate)))) +(defthm scheduling-provides-legal-measure + (let* ((out (inst-scheduling trlst nodeset ntkstate order)) + (newntkstate (mv-nth 3 out)) + (newmeasure (mv-nth 2 out)) + (newtrlst (xy-routing-top (car out) nodeset))) + (implies (and (inst-scheduling-assumptions trlst nodeset ntkstate order) + (trlst-created-by-xy-routing trlst nodeset)) + (ct-legal-measure newmeasure newtrlst nodeset newntkstate order))) + :hints (("Goal" :in-theory (e/d (trlst-created-by-xy-routing) + (scheduler-preserves-created-by-xy)) + :use (:instance scheduler-preserves-created-by-xy)))) + +;; we need the following theorem because otherwise +;; we would have to enable trlstp in theorem 4 +(defthm routing-append-nil + (equal (xy-routing-top (append trlst nil) nodeset) + (xy-routing-top trlst nodeset))) +(defthm consp-routing + (implies (consp missives) + (consp (xy-routing-top missives nodeset)))) + +;; Theorem 4: +;; If the measure initially supplied to GeNoC_t is legal, +;; Property P implies that GeNoC terminates with no +;; en route messages +(defthm en-route-empty + (let* ((nodeset (getcoordinates ntkstate)) + (trlst (XY-routing-top missives nodeset))) + (implies (and (propertyP trlst nodeset ntkstate p1) + (inst-legal-measure measure trlst nodeset ntkstate order)) + (endp (mv-nth 1 (simple-genoc_t missives nodeset measure nil nil time ntkstate order))))) + :hints (("Goal" :in-theory (disable XY-routing-top p1-created-ntkstate deadlockfree ct-scheduling + ct-legal-measure trlstp n==t)))) + +;;------------------------------------------------- +;; THEOREM 5: If en route is empty, all travels +;; have arrived. +;;------------------------------------------------- + +(defthm trlst-equal-routing-missives + (trlst-equal (xy-routing-top missives nodeset) + missives)) +(defthm missives-equal-enroute+arrived + (implies (true-listp missives) + (trlst-equal (append (simple-genoc_t-nt-mv-nth0 missives nodeset measure time ntkstate order) + (simple-genoc_t-nt-mv-nth1 missives nodeset measure time ntkstate order)) + missives)) + :hints (("Goal" :in-theory (disable XY-routing-top ct-scheduling trlst-equal)) + ("Subgoal *1/4" :use (:instance input=output (trlst (xy-routing-top missives nodeset)))))) + +(defthm trlst-equal-append-nil + (implies (endp y) + (trlst-equal (append x y) x)) + :rule-classes :rewrite) + + +(defthm enroute-empty->arrived-full + (implies (and (true-listp missives) + (endp (mv-nth 1 (simple-genoc_t missives nodeset measure nil nil time ntkstate order)))) + (trlst-equal (mv-nth 0 (simple-genoc_t missives nodeset measure nil nil time ntkstate order)) + missives)) + :hints (("Goal" :in-theory (disable XY-routing-top ct-scheduling trlst-equal) + :use ((:instance trlst-equal-append-nil + (x (simple-genoc_t-nt-mv-nth0 missives nodeset measure time ntkstate order)) + (y (simple-genoc_t-nt-mv-nth1 missives nodeset measure time ntkstate order))) + (:instance missives-equal-enroute+arrived))))) + +;;---------------------- +;; PROVING CORRECTNESS +;;---------------------- +(defthm simple-genoc-is-correct + (let ((nodeset (2dMesh-NodesetGenerator p1))) + (mv-let (results aborted) + (simple-genoc trs p1 p2 order) + (declare (ignore aborted)) + (implies (and (transactionsp trs nodeset) + (inst-ValidStateParamsp p1 p2)) + (genoc-correctness results + (extract-sublst trs (r-ids results)))))) + :otf-flg t + :hints (("goal":by + (:functional-instance genoc-is-correct + (generate-initial-ntkstate simple-generate-initial-ntkstate) + (readyfordeparture simple-readyfordeparture) + (genoc simple-genoc) + (genoc_t simple-genoc_t) + (validstateparamsp simple-ValidStateParamsp) + (stategenerator simple-StateGenerator) + (readbuffers simple-readbuffers) + (nodesetgenerator 2DMesh-NodeSetGenerator) + (extract-simulation simple-extract-simulation) + (loadbuffers simple-loadbuffers) + (validparamsp 2DMesh-ValidParamsp) + (nodesetp 2DMesh-NodeSetp) + (scheduling ct-scheduling) + (routing XY-Routing-top) + (get_next_priority ct-get_next_priority) + (scheduling-assumptions ct-scheduling-assumptions) + (legal-measure ct-legal-measure) + (initial-measure ct-initial-measure)) + :in-theory (disable trlstp)) + +; Comment from J Moore for changes after v5-0 for tau: + +; This comment contains (:executable-counterpart tau-system) just so that rune +; is a reliable marker for changes made to support tau. These have had to be +; renamed so often (with changes in tau) that I have lost track of what they +; used to be! Just don't be surprised if this proof fails after changing tau! + +; However, an earlier version of this file had these notes: +; ("Subgoal 32" ; tau on: {"Subgoal 32"} tau off: {"Subgoal 34"} +; :in-theory (disable ct-scheduling xy-routing-top)) +; ("Subgoal 25" ; tau on: {"Subgoal 25"} tau off: {"Subgoal 26"} +; :in-theory (disable ct-scheduling ct-scheduling-assumptions xy-routing-top +; simple-extract-simulation)) +; ("Subgoal 27" ; tau on: {"Subgoal 27"} tau off: {"Subgoal 28"} +; :use (:instance CorrectRoutesp-XYRouting (tmissives m))) +; ("Subgoal 26" ; tau on: {"Subgoal 26"} tau off: {"Subgoal 27"} +; :use (:instance TrLstp-XYRouting (tmissives m))) +; ("Subgoal 13.2'" :use (:instance not-in-v-ids-ct (prev nil))) +; ("subgoal 10" :in-theory (disable consp-last trlstp)) +; ("subgoal 10.2" :in-theory (e/d (trlstp) (consp-last))) +; ("subgoal 10.1" :use ((:instance tm-ids-tomissives-v-ids (x trlst)) +; (:instance tomissives-extract-sublst +; (l (totmissives trlst)) +; (ids (tm-ids (totmissives trlst)))) +; (:instance totmissives-extract-sublst (l trlst) (ids (v-ids trlst))) +; (:instance extract-sublst-identity))) +; ("Subgoal 9" :use (:instance ct-scheduled-correctness (prev nil))) +; ("Subgoal 9.4" :use (:instance ct-delayed-correctness (st ntkstate) (prev nil))) +; ("Subgoal 9.3" :use (:instance subsetp-scheduled-id-ct (prev nil))) +; ("Subgoal 8.2" :use (:instance ct-scheduled-correctness (st ntkstate) (prev nil))))) + + ("Subgoal 30" + :in-theory (disable ct-scheduling xy-routing-top)) + ("Subgoal 23" + :in-theory (disable ct-scheduling ct-scheduling-assumptions xy-routing-top + simple-extract-simulation)) + ("Subgoal 25" + :use (:instance CorrectRoutesp-XYRouting (tmissives m))) + ("Subgoal 24" + :use (:instance TrLstp-XYRouting (tmissives m))) + ("Subgoal 13.2'" :use (:instance not-in-v-ids-ct (prev nil))) + ("Subgoal 8" :in-theory (disable consp-last trlstp)) + ("Subgoal 8.2" :in-theory (e/d (trlstp) (consp-last))) + ("Subgoal 8.1" :use ((:instance tm-ids-tomissives-v-ids (x trlst)) + (:instance tomissives-extract-sublst + (l (totmissives trlst)) + (ids (tm-ids (totmissives trlst)))) + (:instance totmissives-extract-sublst (l trlst) (ids (v-ids trlst))) + (:instance extract-sublst-identity))) + )) + + + diff --git a/books/workshops/2009/verbeek-schmaltz/verbeek/instantiations/genoc/simple-ct-global/trlst-equal.lisp b/books/workshops/2009/verbeek-schmaltz/verbeek/instantiations/genoc/simple-ct-global/trlst-equal.lisp new file mode 100644 index 0000000..9334207 --- /dev/null +++ b/books/workshops/2009/verbeek-schmaltz/verbeek/instantiations/genoc/simple-ct-global/trlst-equal.lisp @@ -0,0 +1,78 @@ +#|$ACL2s-Preamble$; +(begin-book);$ACL2s-Preamble$|# + +(in-package "ACL2") + +(include-book "ordinals/lexicographic-ordering" :dir :system) +(include-book "../../../generic-modules/GeNoC-misc") + +;; We define two lists of messages to be equal +;; if they have the same ids. Order doesn't matter. +;; Since a proof obligation states that the ids are +;; unique, only lists with the same number of messages +;; are unique. +(defun trlst-equal (x y) + (and (subsetp (v-ids x) (v-ids y)) + (subsetp (v-ids y) (v-ids x)))) +(defun member-v (v x) + (member-equal (IdV v) (V-Ids x)))#|ACL2s-ToDo-Line|# + + + + +;; We'll proof trlst-equal is an equivalence relation +;; and proof some congruences concerning append and cons. +(defthm v-ids-append + (equal (v-ids (append a b)) + (append (v-ids a) (v-ids b)))) +(in-theory (disable v-ids-append)) +(defthm append-v-ids-v-ids-append + (equal (append (v-ids trlst1) (v-ids trlst2)) + (v-ids (append trlst1 trlst2)))) +(defthm member-ids-append1 + (implies (member-equal id (V-Ids x)) + (member-equal id (V-Ids (append x y))))) +(defthm member-ids-append2 + (implies (member-equal id (V-Ids y)) + (member-equal id (V-Ids (append x y))))) +(defthm subsetp-v-ids-append1 + (implies (subsetp (v-ids x1) (v-ids x2)) + (subsetp (v-ids (append x1 y)) + (v-ids (append x2 y))))) +(defthm subsetp-v-ids-append2 + (implies (subsetp (v-ids y1) (v-ids y2)) + (subsetp (v-ids (append x y1)) + (v-ids (append x y2))))) +(defthm subsetp-implies-member-v + (implies (and (subsetp (v-ids x) (v-ids y)) + (member-equal id (V-ids x))) + (member-equal id (V-Ids y)))) +(defthm member-equal-idv-v-ids + (implies (member-equal v trlst) + (member-equal (IdV v) (V-Ids trlst)))) + +(defequiv trlst-equal) +(defcong trlst-equal trlst-equal (cons v trlst) 2) +(defcong trlst-equal trlst-equal (append x y) 1) +(defcong trlst-equal trlst-equal (append x y) 2) +(defcong trlst-equal iff (member-v v x) 2) + + + + +(defthm commutativity-of-append2 + (trlst-equal (append x y) (append y x)) + :rule-classes :rewrite + :otf-flg t) +(defthmd append3=append2+1 + (trlst-equal (append x y z) (append (append x y) z))) +(defthm commutativity-of-append3 + (trlst-equal (append x y z) + (append y x z)) + :hints (("Goal" :in-theory (disable trlst-equal associativity-of-append) + :use ((:instance append3=append2+1) + (:instance append3=append2+1 (x y) (y x))))) + :rule-classes :rewrite) + +(defthm trlst-equal-totmissives + (trlst-equal (totmissives trlst) trlst)) diff --git a/books/workshops/2009/verbeek-schmaltz/verbeek/instantiations/interfaces/dummy-interfaces/interfaces-computes.lisp b/books/workshops/2009/verbeek-schmaltz/verbeek/instantiations/interfaces/dummy-interfaces/interfaces-computes.lisp new file mode 100644 index 0000000..44e9755 --- /dev/null +++ b/books/workshops/2009/verbeek-schmaltz/verbeek/instantiations/interfaces/dummy-interfaces/interfaces-computes.lisp @@ -0,0 +1,3 @@ +(in-package "ACL2") + +(include-book "../../../generic-modules/interfaces-computes") diff --git a/books/workshops/2009/verbeek-schmaltz/verbeek/instantiations/nodeset/2DMesh-no-ports/2DMesh.lisp b/books/workshops/2009/verbeek-schmaltz/verbeek/instantiations/nodeset/2DMesh-no-ports/2DMesh.lisp new file mode 100644 index 0000000..5d94a3a --- /dev/null +++ b/books/workshops/2009/verbeek-schmaltz/verbeek/instantiations/nodeset/2DMesh-no-ports/2DMesh.lisp @@ -0,0 +1,140 @@ +#|$ACL2s-Preamble$; +;; Julien Schmaltz +;; July 28th 2005 +;; File: 2D-mesh-nodeset.lisp +;; We define here the coordinates of the nodes in +;; a 2D mesh. +;; We show that it is a valid instance of the +;; generic nodeset definition. +(begin-book);$ACL2s-Preamble$|# + +(in-package "ACL2")#|ACL2s-ToDo-Line|# + + +;------------------------------------- +; the instantiations used in this file +;------------------------------------ +(defmacro inst-NodeSetGenerator (P) + (list '2DMesh-NodeSetGenerator P)) +(defmacro inst-Validparamsp (Params) + (list '2DMesh-Validparamsp Params)) +(defmacro inst-Nodep (x) + (list '2DMesh-Nodep x)) +(defmacro inst-Nodesetp (x) + (list '2DMesh-NodeSetp x)) + + + +(include-book "../../../generic-modules/GeNoC-nodeset") + +;; functions to put elsewhere +(defun rev (x) + ;; reverse a true-list + (if (endp x) + nil + (append (rev (cdr x)) (list (car x))))) + + +;; 1 type of nodes (NodeSetp) +;; ------------------------------ +;; in the mesh topology, nodes are coordinates +(defun 2DMesh-Nodep (x) + (and (consp x) + (consp (cdr x)) + (null (cddr x)) + (natp (car x)) (natp (cadr x)))) + +(defun 2DMesh-NodeSetp (x) + (if (endp x) + t + (and (2DMesh-Nodep (car x)) + (2DMesh-NodeSetp (cdr x))))) + +;; this function will be mapped to NodeSetp in +;; the functional instanciation + +;; 2 nodeset generator (NodeSetGenerator) +;; --------------------------------------- + +(defun x-dim-gen (X y) + ;; generate the nodes along the x-dim, y is a constant + (declare (xargs :guard (and (natp X) (natp y)))) + (if (zp X) + nil + (cons (list (1- X) y) (x-dim-gen (1- X) y)))) + +(defthm all-coordinatep-x-dim-gen + ;; x-dim-gen produces valid coordinates + (implies (and (natp x) (natp y)) + (2DMesh-NodeSetp (x-dim-gen x y)))) + + +(defun coord-generator-1 (X Y) + ;; generate a list of coordinates + (if (zp Y) + nil + (append (x-dim-gen X (1- y)) + (coord-generator-1 X (1- Y))))) + +(defthm valid-coordinates-coord-gen-1 + (implies (and (natp x) (natp y)) + (2DMesh-NodeSetp (coord-generator-1 x y)))) + +(defun coord-gen (X Y) + (rev (coord-generator-1 X Y))) + +(defthm valid-coordinates-coord-gen + (implies (and (natp x) (natp y)) + (2DMesh-NodeSetp (coord-gen x y)))) + +(defthm truelistp-coord-gen + (true-listp (coord-gen x y)) + :rule-classes :type-prescription + ) + +;; as coord-gen is non-recursive function, we disable it +(in-theory (disable coord-gen)) + + +;; 3. Parameters +;; ------------ + +(defun 2DMesh-Validparamsp (Params) + ;; hyps on the parameters + ;; Params is a consp as well as its cdr + ;; each element of the cons is a natural + (and (consp Params) (consp (cdr Params)) (null (cddr Params)) + (natp (car Params)) (natp (cadr Params)))) + +;; P is a list (x, y) +(defun 2DMesh-NodeSetGenerator (P) + ;; NODE SET GENERATOR + (coord-gen (car P) (cadr P))) + +;; this function will be mapped to +;; NodeSetGenerator + +;; 4. Prove the last constraint (subsetp) +;; -------------------------------------- +(defthm subsets-are-valid-mesh-nodesetp + (implies (and (2DMesh-NodeSetp x) + (subsetp y x)) + (2DMesh-NodeSetp y))) + + + +;; the next lemma is needed for the instances (like XY Routing) +;(defthm 2d-mesh-nodesetgenerator +; (implies (mesh-hyps params) +; (2d-mesh-nodesetp (mesh-nodeset-gen params)))) + +;; 5. check that these definitions are compliant +;; with the generic encapsulate +;; --------------------------------------------- +(definstance GenericNodeSet Mesh-Complies-NodeSet + :functional-substitution + ((NodeSetGenerator 2DMesh-NodeSetGenerator) + (ValidParamsp 2DMesh-Validparamsp) + (Nodep 2DMesh-Nodep) + (Nodesetp 2DMesh-NodeSetp))) + diff --git a/books/workshops/2009/verbeek-schmaltz/verbeek/instantiations/ntkstate/simple/simple.lisp b/books/workshops/2009/verbeek-schmaltz/verbeek/instantiations/ntkstate/simple/simple.lisp new file mode 100644 index 0000000..b37f270 --- /dev/null +++ b/books/workshops/2009/verbeek-schmaltz/verbeek/instantiations/ntkstate/simple/simple.lisp @@ -0,0 +1,193 @@ +#|$ACL2s-Preamble$; +(begin-book);$ACL2s-Preamble$|# + +(in-package "ACL2") + +(include-book "../../../generic-modules/GeNoC-ntkstate") +(include-book "../../nodeset/2DMesh-no-ports/2DMesh") + +;; simple-ntkstate = (entry1, entry2, ...) +;; simple-entry = (((Coor (X1 Y1)) (Buffers data))) +;; where data = (consp b_1 b_2 b_3 ... b_c) with c a constant + + +(defconst *num-of-buffers* 3) + +(defun nil-list (n) + (if (zp n) + nil + (cons nil (nil-list (1- n))))) + +(defun simple-Stategeneratorlocal (nodeset) + (if (endp nodeset) + nil + (append (list (list (list 'Coor (car nodeset)) + (list 'Buffers (nil-list *num-of-buffers*)))) + (simple-StateGeneratorlocal (cdr nodeset))))) + +;;Generates the states +;;P is the parameter for the NodeSetGenerator +;;The other parameter isn't used +(defun simple-StateGenerator (P optional-param) + (declare (ignore optional-param)) + (simple-stategeneratorlocal (2DMesh-NodeSetGenerator P))) + +;; A function that verifies the the input parameters of the state +;; generation function +(defun simple-ValidStateParamsp (P optional-param) + (declare (ignore optional-param)) + (2DMesh-ValidParamsp P)) +(in-theory (disable simple-ValidStateParamsp)) + +;; Updates the buffer bufnum of the entry with the new content +(defun update-buffer (entry content) + (if (endp entry) + (list (list 'Coor nil) (list 'Buffers (nil-list *num-of-buffers*))) + (list (car entry) (list 'Buffers content)))) + + +;; this function takes as input a list with as first elt +;; the coordinates of a node and as second the buffer nummer. +;; It loads the buffer with the content +;; returns: updated networkstate +(defun simple-loadbuffers (node-coor content ntkstate) + (if (endp ntkstate) + nil + (let* ((entry (car ntkstate)) + (curr_coor (get_coor entry))) + (if (equal node-coor curr_coor) + ;; we have found the right element + (cons (update-buffer entry content) (cdr ntkstate)) + ;; else keep searching + (cons entry + (simple-loadbuffers node-coor content (cdr ntkstate))))))) +(defun simple-readbuffers (node-coor ntkstate) + (if (endp ntkstate) + nil + (let ((entry (car ntkstate))) + (if (equal (get_coor entry) node-coor) + ;; we have found the right element, we return it + entry + ;; else we keep searching + (simple-readbuffers node-coor (cdr ntkstate)))))) +;; returns t iff the entry has a buffer equal to nil +(defun has-empty-buffer (entry) + (member-equal nil (get_buff entry)))#|ACL2s-ToDo-Line|# + + +;;----------------------- +;; update ntkstate +;;----------------------- +;; creates a list of all travels currently in node +(defun get-travels (node trlst) + (if (endp trlst) + nil + (let ((recur (get-travels node (cdr trlst)))) + (if (equal (caar (RoutesV (car trlst))) node) + (cons (car trlst) recur) + recur)))) +;; creates a bufffer with length 'size' +;; puts all frms in the buffer if possible +(defun create-buffer (size travels) + (cond ((zp size) nil) + ((endp travels) (nil-list size)) + (t + (cons (FrmV (car travels)) (create-buffer (1- size) (cdr travels)))))) +(defun update-ntkstate (ntkstate trlst) + (if (endp ntkstate) + nil + (let* ((entry (car ntkstate)) + (coor (get_coor entry))) + (cons (update-buffer entry (create-buffer *num-of-buffers* (get-travels coor trlst))) + (update-ntkstate (cdr ntkstate) trlst))))) + + + + +;; generate the initial ntkstate from a transaction list +;; creates a list of all travels currently in node +(defun get-transactions (node talst) + (if (endp talst) + nil + (let ((recur (get-transactions node (cdr talst))) + (currTa (car talst))) + (if (equal (OrgT currTa) node) + (cons currTa recur) + recur)))) +(defun create-buffer-ta (size transactions) + (cond ((zp size) nil) + ((endp transactions) (nil-list size)) + (t + (cons (MsgT (car transactions)) (create-buffer-ta (1- size) (cdr transactions)))))) +(defun simple-generate-initial-ntkstate (talst ntkstate) + (if (endp ntkstate) + nil + (let* ((entry (car ntkstate)) + (coor (get_coor entry))) + (cons (update-buffer entry (create-buffer-ta *num-of-buffers* (get-transactions coor talst))) + (simple-generate-initial-ntkstate talst (cdr ntkstate)))))) + + + +;------------------------------------- +; the instantiations used in this file +;------------------------------------ +(defmacro inst-readbuffers (node-id ntkstate) + (list 'simple-readbuffers node-id ntkstate)) +(defmacro inst-loadbuffers (node-id frm ntkstate) + (list 'simple-loadbuffers node-id frm ntkstate)) +(defmacro inst-generate-initial-ntkstate (talst ntkstate) + (list 'simple-generate-initial-ntkstate talst ntkstate)) +(defmacro inst-StateGenerator (P optional-param) + (list 'simple-StateGenerator P optional-param)) +(defmacro inst-ValidStateParamsp (P optional-param) + (list 'simple-ValidStateParamsp P optional-param)) + +;-------------- +; Theorems +;-------------- +(defthm simple-gen-validstates + (implies (simple-validstateparamsp P1 P2) + (Validstate (simple-stategeneratorlocal NodeSet)))) +(defthm Stateparamsp=Paramsp + (implies (simple-validstateparamsp P1 P2) + (2DMesh-Validparamsp P1)) + :hints (("Goal" :use (:instance simple-ValidStateParamsp (P P1) (optional-param P2))) +)) +(defthm simple-loadbufbers-validstates + (implies (ValidState ntkstate) + (ValidState (SIMPLE-LOADBUFFERS node-coor content ntkstate))) +) + +(defthm simple-readbuffers-valid-entryp-local + (implies + (validstate ntkstate) + (ValidState-entryp (simple-readbuffers node-coor ntkstate)))) +(defthm validstate-update-ntkstate + (implies (validstate ntkstate) + (validstate (update-ntkstate ntkstate trlst)))) +(defthm validstate-simple-generate-initial-ntkstate + (implies (validstate ntkstate) + (validstate (simple-generate-initial-ntkstate talst ntkstate)))) + +(defthm nodesetp-coordinates-simple + (implies (true-listp NodeSet) + (equal (getcoordinates (simple-StateGeneratorlocal NodeSet)) + NodeSet))) + +;-------------- +; Compliance +;-------------- +(definstance GenericNodesetbuffers simple-ntkstate-complies-generic + :functional-substitution + ((ValidParamsp 2DMesh-Validparamsp) + (NodeSetGenerator 2DMesh-NodeSetGenerator) + (loadbuffers simple-Loadbuffers) + (readbuffers simple-Readbuffers) + (StateGenerator simple-StateGenerator) + (generate-initial-ntkstate simple-generate-initial-ntkstate) + (ValidstateParamsp simple-ValidStateParamsp)) + :otf-flg t + :hints (("Goal" :in-theory (disable ValidState-entryp simple-ValidStateParamsp ValidState)) + ("Subgoal 1" :use (:instance nodesetp-coordinates-simple)) +)) diff --git a/books/workshops/2009/verbeek-schmaltz/verbeek/instantiations/routing/XY/XYRouting.lisp b/books/workshops/2009/verbeek-schmaltz/verbeek/instantiations/routing/XY/XYRouting.lisp new file mode 100644 index 0000000..77d4359 --- /dev/null +++ b/books/workshops/2009/verbeek-schmaltz/verbeek/instantiations/routing/XY/XYRouting.lisp @@ -0,0 +1,508 @@ +#|$ACL2s-Preamble$; +(begin-book);$ACL2s-Preamble$|# + +(in-package "ACL2") +;; we import the generic definition +(include-book "../../../generic-modules/GeNoC-routing") +;; we import the book with node definition for a 2D-mesh +(include-book "../../nodeset/2DMesh-no-ports/2DMesh") + + +;; we load the arithmetic books +(include-book "arithmetic-3/bind-free/top" :dir :system) +(include-book "arithmetic-3/floor-mod/floor-mod" :dir :system) + + + +;; we define a new measure in this part taking into consideration +;; the difference between the input and output port +;; the objective is to consider the intra router routing a true hop to +;; be able to +;; implement the routing as it is presented in the book +;; this way the measure decreases also in the case of the intra +;; routing on the same node. + +(defun XY-measure (current to) + (let ((x_d (car to)) + (y_d (cadr to)) + (x_o (car current)) + (y_o (cadr current))) + (nfix (+ (abs (- x_d x_o)) (abs (- y_d y_o)))))) + +(defthm O-P-XY-routing-with-ports + ;; the measure must be an ordinal + (O-P (XY-measure from to))) + +(defun move-north (current) + (list (car current) (1- (cadr current)))) +(defun move-south (current) + (list (car current) (1+ (cadr current)))) +(defun move-east (current) + (list (1+ (car current)) (cadr current))) +(defun move-west (current) + (list (1- (car current)) (cadr current))) + +(defun XYRoutingLogic (current to) + (let ((x_d (car to)) + (y_d (cadr to)) + (x_o (car current)) + (y_o (cadr current))) + (if (not (equal x_d x_o)) + (if (< x_d x_o) + (move-west current) + (move-east current)) + (if (< y_d y_o) + (move-north current) + (move-south current))))) + +(defun XYrouting (current to) + (declare (xargs :measure (XY-measure current to))) + (if (or (not (2DMesh-Nodep current)) (not (2DMesh-Nodep to))) + nil + (let ((x_d (car to)) + (y_d (cadr to)) + (x_o (car current)) + (y_o (cadr current))) + (if (and (equal x_d x_o) (equal y_d y_o)) + (cons current nil) + (cons current (XYrouting (XYRoutingLogic current to) to)))))) + +(defthm first-XY-routing + ;; the first element is the origin + (implies (and (2DMesh-Nodep current) + (2DMesh-Nodep to)) + (equal (car (XYrouting current to)) + current))) + +(defthm last-XY-routing + ;; the last element is the destination + (implies (and (2DMesh-Nodep current) + (2DMesh-Nodep to)) + (equal (car (last (XYrouting current to))) + to))) +(defun all-x-<-max (L x-max) + ;; we define a function that checks that every x-coordinate is less + ;; than x-max + (if (endp L) + t + (and (< (caar L) x-max) ;; x_i < x-max + (all-x-<-max (cdr L) x-max)))) + +(defun all-y-<-max (L y-max) + ;; we define a function that checks that every y-coordinate is less + ;; than y-max + (if (endp L) + t + (and (< (cadar L) y-max) ;; y_i < y-max + (all-y-<-max (cdr L) y-max)))) + +(defthm member-equal-x-dim-gen + ;; we prove that if x is a coordinate with its first part less than x-dim + ;; and its second part equal to y-dim then x is a member of x-dim-gen. + (implies (and (2DMesh-Nodep x) + (< (car x) x-dim) + (natp x-dim) + (natp y-dim) + (equal (cadr x) y-dim)) + (member-equal x (x-dim-gen x-dim y-dim)))) + +(defthm member-coord-generator-1 + ;; we prove something similar for the function coord-generator-1 + ;; both parts of x are less than x-dim and y-dim implies that x + ;; is a member of coord-generator-1 + (implies (and (2DMesh-Nodep x) + (natp y-dim) + (natp x-dim) + (< (car x) x-dim) + (< (cadr x) y-dim)) + (member-equal x (coord-generator-1 x-dim y-dim)))) + +(defthm tactic1 + ;; we prove that our tactic is valid for membership + (implies (and (2DMesh-NodeSetp L) + (consp L) + (all-x-<-max L x-dim) + (natp x-dim) + (all-y-<-max L y-dim) + (natp y-dim)) + (member-equal (car L) (coord-generator-1 x-dim y-dim)))) + +(defthm member-equal-rev + ;; this should go elsewhere + (implies (member-equal x S) + (member-equal x (rev S)))) + +(defthm tactic1-top + ;; we now prove that our tactic is valid + (implies (and (2DMesh-NodeSetp L) + (all-x-<-max L x-dim) (natp x-dim) + (all-y-<-max L y-dim) (natp y-dim)) + (subsetp L (coord-gen x-dim y-dim))) + :hints (("GOAL" + :in-theory (enable coord-gen)))) + +;; Then the strategy is to prove that XY-routing-with-ports satisfies +;; the hypotheses of this theorem +(defthm 2D-mesh-NodeSet-XY-routing + ;; 1st hyp is trivial + ;; a route is a list of valid coordinates + (2DMesh-NodeSetp (XYrouting current to))) + +(defthm x-<all + (implies (and (2DMesh-NodeSetp L) + (all-x-<-max L (car from))) + (all-x-<-max L (1+ (car from))))) + +(defthm x-1<all + (implies (and (2DMesh-NodeSetp L) + (all-x-<-max L (1- (car from)))) + (all-x-<-max L (1+ (car from))))) + +(defthm y-<all + (implies (and (2DMesh-NodeSetp L) + (all-y-<-max L (cadr from))) + (all-y-<-max L (1+ (cadr from))))) + +(defthm y-1<all + (implies (and (2DMesh-NodeSetp L) + (all-y-<-max L (1- (cadr from)))) + (all-y-<-max L (1+ (cadr from))))) + +;; let's go to the more tricky part. +;; First, every x-coord of any nodes produced by function XY-routing-with-ports +;; is strictly less than 1 + Max(from_x, to_x)(2D-mesh-nodeset-portsp +;; (xy-routing-with-ports from to)) + +(defthm all-x-<-max-minus-1 + ;; lemma needed to be able to enlarge the majoration + (implies (all-x-<-max L (1- x)) + (all-x-<-max L x))) + +(defthm all-x-<-max-x-dim-gen + ;; we prove that x-dim-gen generates nodes with x-coord < x + (all-x-<-max (x-dim-gen x y) x)) + +(defthm all-x-<-max-coord-gen + ;; we propagate this property to coord-generator-1 which calls x-dim-gen + (all-x-<-max (coord-generator-1 x y) x)) +(defthm all-x-<-max-member-equal + (implies (and (all-x-<-max L x) + (member-equal y L)) + (< (car y) x))) + +(defthm all-x-<-max-rev + ;; all-x-<-max is preserved if we reverse its arguments + (implies (all-x-<-max L x) + (all-x-<-max (rev L) x))) + +(defthm all-y-<-max-x-dim-gen + (all-y-<-max (x-dim-gen x y) (+ 1 y))) + +(defthm all-y-<-max-minus-1 + (implies (all-y-<-max L (+ -1 x)) + (all-y-<-max L x))) + +(defthm all-y-<-max-append + (implies (and (all-y-<-max L1 x) + (all-y-<-max L2 x)) + (all-y-<-max (append L1 L2) x))) + +(defthm all-y-<-max-coord-gen-1 + (all-y-<-max (coord-generator-1 x y) y) + :hints (("SubGoal *1/2" + :cases ((all-y-<-max (x-dim-gen x (+ -1 y)) y))) + ("SubGoal *1/2.2" + :use (:instance all-y-<-max-x-dim-gen (y (+ -1 y))) + :in-theory (disable all-y-<-max-x-dim-gen)))) + +(defthm rev-append + ;; should be put elsewhere + (equal (rev (append x y)) + (append (rev y) (rev x)))) + +(defthm all-y-<-max-rev + (implies (all-y-<-max L x) + (all-y-<-max (rev L) x))) + +(defthm routing-all-x-less + (all-x-<-max (XYrouting current to) + (1+ (max (car current) (car to)))) + :hints (("Goal" + :in-theory (disable CONSP-APPEND REDUCE-INTEGERP-+ + INTEGERP-MINUS-X)))) + + + +(defthm routing-all-y-less + (all-y-<-max (XYrouting current to) + (1+ (max (cadr current) (cadr to))))) + +(defthm XY-routing-with-ports-subsetp-coord-max + (implies (and (2DMesh-Nodep current) (2DMesh-Nodep to)) + (subsetp (XYrouting current to) + (coord-gen (1+ (max (car current) (car to))) + (1+ (max (cadr current) (cadr to)))))) + :hints (("GOAL" + :in-theory (disable max)))) + +(defthm all-max-coord-gen + (and (all-x-<-max (coord-gen X Y) X) + (all-y-<-max (coord-gen X Y) Y)) + :hints (("GOAL" + :in-theory (enable coord-gen)))) + +;; now we prove that if (x1 y1) and (x2 y2) belong to (coord-gen NX NY) +;; then Max(x1, x2) < NX and Max(y1, y2) < NY + +(defthm member-equal-x-dim-gen-plus + (implies (and (<= x1 x2) (natp x1) (< 0 x1) (natp x2)) + ( and (member-equal (list (+ -1 x1) y) + (x-dim-gen x2 y)) ))) +(defthm subsetp-x-dim-gen-plus + (implies (and (natp x1) (natp x2) (<= x1 x2)) + (subsetp (x-dim-gen x1 y) + (x-dim-gen x2 y)))) + +(defthm subsetp-append-2 + ;; should be put elsewhere + (implies (and (subsetp x L) + (subsetp y L)) + (subsetp (append x y) L))) + +(defthm all-y-<-max-member-equal + (implies (and (all-y-<-max L y) + (member-equal e L)) + (< (cadr e) y))) + +(defthm all-max-member-equal + (implies (and (member-equal x L) + (all-x-<-max L x-max) + (all-y-<-max L y-max) + (member-equal y L)) + (and (< (max (car x) (car y)) x-max) + (< (max (cadr x) (cadr y)) y-max)))) + +;; then we prove that if x < NX and y < NY then +;; (coord-gen x y) is a subset of (coord-gen NX NY) + +(defthm subsetp-x-dim-gen-coord-gen-1 + (implies (and (natp x1) + (natp x2) + (natp y1) + (natp y2) + (<= x1 x2) + (< y1 y2)) + (subsetp (x-dim-gen x1 y1) + (coord-generator-1 x2 y2)))) + +(defthm subsetp-coord-gen-1 + (implies (and (<= x1 x2) + (<= y1 y2) + (natp x1) + (natp x2) + (natp y1) + (natp y2)) + (subsetp (coord-generator-1 x1 y1) + (coord-generator-1 x2 y2)))) + +(defthm subsetp-rev-2 + ;; should go elsewhere + (implies (subsetp x y) + (subsetp (rev x) (rev y)))) + +;; here comes our main lemma: +(defthm subsetp-coord-plus + (implies (and (<= x1 x2) (<= y1 y2) + (natp x1) (natp x2) (natp y1) (natp y2)) + (subsetp (coord-gen x1 y1) + (coord-gen x2 y2))) + :hints (("GOAL" + :in-theory (enable coord-gen)))) + +;; and now using the transitivity of subsetp we conclude: +(defthm trans-subsetp + ;; should be put elsewhere + (implies (and (subsetp x y) + (subsetp y z)) + (subsetp x z))) + +(defthm XY-routing-with-ports-subsetp-nodeset + ;; now we want to prove that if NodeSet = coord-gen x y, then + ;; route is a subsetp of NodeSet. + ;; current and to must be members of NodeSet + ;; current and to must not be equal + (implies (and (not (equal current to)) + (2DMesh-Nodep current) + (2DMesh-Nodep to) + (natp X) + (natp Y) + ;; it should be member-equal + (member-equal current (coord-gen X Y)) + (member-equal to (coord-gen X Y))) + (subsetp (XYrouting current to) (coord-gen X Y))) + :otf-flg t + :hints (("GOAL" + :use ((:instance all-max-member-equal + (L (coord-gen X Y)) + (x current) (y to) + (x-max X) (y-max Y)) + (:instance XY-routing-with-ports-subsetp-coord-max)) + :do-not '(eliminate-destructors generalize fertilize) + :in-theory (disable coord-gen 2DMesh-Nodep natp subsetp + all-max-member-equal + XY-routing-with-ports-subsetp-coord-max) + :do-not-induct t) + ("Subgoal 4" + :use (:instance subsetp-coord-plus + (x1 (+ 1 (car current))) (x2 x) + (y1 (+ 1 (cadr current))) (y2 y)) + :in-theory (disable subsetp-coord-plus + coord-gen subsetp)) + ("Subgoal 3" + :use (:instance subsetp-coord-plus + (x1 (+ 1 (car current))) (x2 x) + (y1 (+ 1 (cadr to))) (y2 y)) + :in-theory (disable subsetp-coord-plus + coord-gen subsetp)) + ("Subgoal 2" + :use (:instance subsetp-coord-plus + (x1 (+ 1 (car to))) (x2 x) + (y1 (+ 1 (cadr current))) (y2 y)) + :in-theory (disable subsetp-coord-plus + coord-gen subsetp)) + ("Subgoal 1" + :use (:instance subsetp-coord-plus + (x1 (+ 1 (car to))) (x2 x) + (y1 (+ 1 (cadr to))) (y2 y)) + :in-theory (disable subsetp-coord-plus + coord-gen subsetp)))) + +(set-irrelevant-formals-ok t) +(defun XY-routing-top (Missives nodeset) + ;;(declare (ignore nodeset)) + (if (endp Missives) + nil + (let* ((miss (car Missives)) + (From (OrgTM miss)) + (current (CurTM miss)) + (to (DestTM miss)) + (id (IdTM miss)) + (frm (FrmTM miss)) + (flits (FlitTM miss)) + (Time (TimeTM miss))) + (cons (list id from frm (list (XYrouting current to)) flits time) + (XY-routing-top (cdr Missives) nodeset))))) + +(set-irrelevant-formals-ok nil) + +(defun XYRouting-main (Missives NodeSet) + ;;(declare (ignore NodeSet)) + (XY-routing-top Missives nodeset)) + +;; 4.b Proof of compliance +;; ------------------------ + +(defthm xy-routing-nil + ;; the routing has to return nil if the list of missives is nil + (not (xy-routing-top nil NodeSet))) + +(defthm true-listp-xy- + (true-listp (xy-routing-top missives nodeset))) + +;; 2. TrLstp +;;the next four theorems are necessary lemmas to prove the theorem +;;Trlstp-XY-routing + +(defthm consp-XY-routing-with + ;; should be systematically added (35 secondeS) + (implies (and (2DMesh-Nodep current) + (2DMesh-Nodep to)) + (consp (XYrouting current to)))) + +(defthm consp-XY-routing-with-ports-cdr + ;; should be systematically added + (implies (and (2DMesh-Nodep current) (not (equal current to)) + (2DMesh-Nodep to)) + (consp (cdr (XYrouting current to))))) + +(defthm V-ids-XY-routing-with-ports-=-M-ids + ;; this one too ... + (equal (V-ids (XY-routing-top Missives nodeset)) + (TM-ids Missives))) + +(defthm 2D-mesh-NodeSet-portsp-member-equal + (implies (and (2DMesh-NodeSetp x) + (member-equal e x)) + (2DMesh-Nodep e))) + +(defthm no-consecutive-equals-XY-Routing + (implies (and (2DMesh-Nodep current) + (2DMesh-Nodep to)) + (no-consecutive-equals (XYrouting current to)))) +(defthm no-hops-equal-to-dest-XY-Routing + (implies (and (2DMesh-Nodep current) + (2DMesh-Nodep to)) + (no-hops-equal-to-dest (XYrouting current to) to))) + +(defthm TrLstp-XYRouting + (let ((NodeSet (2dMesh-NodesetGenerator Params))) + (implies (and (TMissivesp TMissives NodeSet) + (2DMesh-Validparamsp Params)) + (TrLstp (XY-routing-top TMissives nodeset) nodeset))) + :hints (("GOAL" :induct (XY-routing-top tmissives nodeset)) + ("Subgoal *1/2" + :use ((:instance last-XY-routing + (current (CADDAR TMISSIVES)) + (to (CADDDR (CDAR TMISSIVES)))) + (:instance 2D-mesh-NodeSet-portsp-member-equal + (x (2DMesh-NodeSetGenerator Params)) + (e (OrgtM (car tMissives)))) + (:instance 2D-mesh-NodeSet-portsp-member-equal + (x (2DMesh-NodeSetGenerator Params)) + (e (CurtM (car tMissives)))) + (:instance 2D-mesh-NodeSet-portsp-member-equal + (x (2DMesh-NodeSetGenerator Params)) + (e (DesttM (car tMissives))))) + :in-theory (disable 2D-mesh-NodeSet-portsp-member-equal + 2DMesh-Nodep last-XY-routing)))) + +;; 3. CorrectRoutesp +(defthm CorrectRoutesp-XYRouting + (let ((NodeSet (2DMesh-NodeSetGenerator Params))) + (implies (and (2dMesh-ValidParamsp Params) + (TMissivesp TMissives NodeSet)) + (CorrectRoutesp (XY-routing-top TMissives nodeset) + TMissives NodeSet))) + :hints (("GOAL" + :induct (XY-routing-top TMissives nodeset) + :do-not-induct t) + ("Subgoal *1/2" + :use ((:instance first-XY-routing + (current (CADDAR TMISSIVES)) + (to (CADDDR (CDAR TMISSIVES)))) + (:instance 2D-mesh-NodeSet-portsp-member-equal + (x (2DMesh-NodeSetGenerator Params)) + (e (CurTM (car TMissives)))) + (:instance 2D-mesh-NodeSet-portsp-member-equal + (x (2DMesh-NodeSetGenerator Params)) + (e (OrgTM (car TMissives)))) + (:instance 2D-mesh-NodeSet-portsp-member-equal + (x (2DMesh-NodeSetGenerator Params)) + (e (DestTM (car TMissives))))) + :in-theory (disable 2D-mesh-NodeSet-portsp-member-equal + 2DMesh-Nodep)))) + +(definstance GenericRouting check-comlpiance-xyrouting + :functional-substitution + ((NodeSetGenerator 2DMesh-NodeSetGenerator) + (NodeSetp 2DMesh-NodeSetp) + (ValidParamsp 2DMesh-ValidParamsp) + (Routing XY-Routing-top)) + :rule-classes nil + :hints (("GOAL" :in-theory (disable ToMissives-Routing + 2DMesh-NodeSetGenerator + trlstp 2DMesh-ValidParamsp + TMissivesp)) + ("Subgoal 5" + :in-theory (enable 2DMesh-ValidParamsp))) + :otf-flg t) diff --git a/books/workshops/2009/verbeek-schmaltz/verbeek/instantiations/scheduling/circuit-switching-global/circuit.lisp b/books/workshops/2009/verbeek-schmaltz/verbeek/instantiations/scheduling/circuit-switching-global/circuit.lisp new file mode 100644 index 0000000..60d65ad --- /dev/null +++ b/books/workshops/2009/verbeek-schmaltz/verbeek/instantiations/scheduling/circuit-switching-global/circuit.lisp @@ -0,0 +1,604 @@ +#|$ACL2s-Preamble$; +;; Julien Schmaltz +;; File: circuit-scheduling.lisp +;; here we define a function that realises a circuit switching +;; technique, we prove it correct and we prove that it is a valid +;; instance of the scheduling function of GeNoC. +;; Revised: Nov 13th 2005, JS + +(begin-book);$ACL2s-Preamble$|# + +(in-package "ACL2") +(include-book "../../../generic-modules/GeNoC-scheduling") +(include-book "intersect") +(include-book "../../ntkstate/simple/simple") +(include-book "../../synchronization/circuit-global/circuit") +(include-book "../../genoc/simple-ct-global/trlst-equal") + +;;----------------------------------------------------- +;; +;; DEFINITION OF THE CIRCUIT SWITCHED SCHEDULING POLICY +;; +;;----------------------------------------------------- + + +(defun test_prev_routes (r? prev) + ;; function that returns a route that uses nodes + ;; that are not in prev or returns nil if there is no + ;; such route. + (cond ((endp r?) + nil) + ((endp prev) + t) + ((no_intersectp r? (car prev)) + (test_prev_routes r? (cdr prev))) + (t + nil))) + +(defun ct-scheduler (TrLst Scheduled Arrived prev measureAcc ntkstate) + (if (endp trlst) + (mv (rev Scheduled) (rev Arrived) (rev measureAcc) ntkstate) + (let ((v (car TrLst))) + (mv-let (newntkstate r?) + (inst-test_routes ntkstate v) + (if (test_prev_routes r? prev) + ;; if there is a possible route, then remove + ;; it and add it to to prev + (ct-scheduler (cdr TrLst) + Scheduled + (cons v Arrived) + (cons r? prev) + (cons 0 measureAcc) + newntkstate) + ;; otherwise the transaction is delayed + (ct-scheduler (cdr TrLst) + (cons v Scheduled) + Arrived + prev + (cons (len (car (RoutesV (car TrLst)))) measureAcc) + newntkstate)))))) + +;; returns t if there's no route possible in +;; the current ntkstate +(defun no-good-routes (TrLst ntkstate) + (if (endp trlst) + t + (mv-let (newntkstate r?) + (inst-test_routes ntkstate (car trlst)) + (if (not r?) + (no-good-routes (cdr TrLst) newntkstate) + nil)))) + +(defun sum-of-lst (lst) + (if (endp lst) + 0 + (nfix (+ (car lst) (sum-of-lst (cdr lst)))))) + +;; returns a list of the lengths of the routes of the travels in TrLst +(defun RouteLengths-TrLst (TrLst) + (if (endp TrLst) + nil + (cons (len (car (RoutesV (car TrLst)))) (RouteLengths-TrLst (cdr TrLst))))) +; the measure is a list of lengths of the routes +(defun ct-initial-measure (trlst nodeset ntkstate order) + (declare (ignore nodeset ntkstate order)) + (sum-of-lst (RouteLengths-TrLst trlst))) +(defun ct-legal-measure (measure TrLst NodeSet ntkstate order) + (declare (ignore nodeset ntkstate order)) + (equal measure (sum-of-lst (RouteLengths-Trlst trlst)))) +(defun ct-get_next_priority (x) + x) + +; circuit scheduling assume that: +; 1.) the TrLst is not empty +; 2.) there is at least one route possible +; 3.) the current measure is a list with the lengths of the current routes +(defun ct-scheduling-assumptions (TrLst NodeSet ntkstate order) + (declare (ignore NodeSet order)) + ; (and (not (endp TrLst)) + (not (no-good-routes TrLst ntkstate))) + + +;Scheduling: +; IN: List of Travels +; Measure +; NodeSet +; ntkstate +; order +; OUT: List of En Route TMs +; List of Arrived Travels +; Valid networkstate +(defun ct-scheduling (TrLst NodeSet ntkstate order) + (if (not (ct-scheduling-assumptions TrLst NodeSet ntkstate order)) + (mv (totmissives TrLst) nil nil ntkstate) + ; otherwise: schedule the travels + (mv-let (newTrlst Arrived newmeasure newntkstate) + (ct-scheduler TrLst nil nil nil nil ntkstate) + (mv (totmissives newTrlst) + Arrived + (sum-of-lst newmeasure) + (update-ntkstate newntkstate newtrlst))))) + +;------------------------------------- +; the instantiations used in this file +;------------------------------------ +(defmacro inst-scheduling (TrLst NodeSet ntkstate order) + (list 'ct-scheduling TrLst NodeSet ntkstate order)) +(defmacro inst-scheduling-assumptions (TrLst NodeSet ntkstate order) + (list 'ct-scheduling-assumptions TrLst NodeSet ntkstate order)) +(defmacro inst-legal-measure (measure TrLst nodeset ntkstate order) + (list 'ct-legal-measure measure TrLst nodeset ntkstate order)) +(defmacro inst-initial-measure (TrLst nodeset ntkstate order) + (list 'ct-initial-measure TrLst nodeset ntkstate order)) +(defmacro inst-get_next_priority (order) + (list 'ct-get_next_priority order)) + + +;----------------------------------------------- +; +; PROVING COMPLIANCE TO GENERIC SCHEDULING +; +; +; The proof is completely equal to the proof +; of packet-scheduling. +; +;----------------------------------------------- + +;------------------------------- +; non-tail recursive functions +; for ct-scheduler +;------------------------------- +(defun ct-scheduler-nt-car (TrLst prev ntkstate) + ;; car is the first output and corresponds to the scheduled travels + (if (endp TrLst) + nil + (let ((v (car TrLst))) + (mv-let (newntkstate r?) + (inst-test_routes ntkstate v) + (if (test_prev_routes r? prev) + (ct-scheduler-nt-car (cdr TrLst) (cons r? prev) + newntkstate) + (cons v (ct-scheduler-nt-car (cdr TrLst) prev + newntkstate))))))) +(defthm ct-scheduler-nt-equal + (equal (car (ct-scheduler TrLst Scheduled ArrivedAcc prev measureAcc ntkstate)) + (append (rev scheduled) (ct-scheduler-nt-car TrLst prev ntkstate))) + :hints (("Goal" :in-theory (disable ct-test_routes)))) + +(defun ct-scheduler-nt-mv1 (TrLst prev ntkstate) + (if (endp TrLst) + nil + (let ((v (car TrLst))) + (mv-let (newntkstate r?) + (inst-test_routes ntkstate v) + (if (test_prev_routes r? prev) + (cons v (ct-scheduler-nt-mv1 (cdr TrLst) (cons r? prev) + newntkstate)) + (ct-scheduler-nt-mv1 (cdr TrLst) prev + newntkstate)))))) +(defthm ct-scheduler-nt-mv1-equal + (equal (mv-nth 1 (ct-scheduler TrLst Scheduled ArrivedAcc prev measureAcc ntkstate)) + (append (rev ArrivedAcc) (ct-scheduler-nt-mv1 TrLst prev ntkstate))) + :hints (("Goal" :in-theory (disable ct-test_routes)))) + +(defun ct-scheduler-nt-mv2 (TrLst prev ntkstate) + (if (endp TrLst) + nil + (let ((v (car TrLst))) + (mv-let (newntkstate r?) + (inst-test_routes ntkstate v) + (if (test_prev_routes r? prev) + (cons 0 + (ct-scheduler-nt-mv2 (cdr TrLst) (cons r? prev) + newntkstate)) + (cons (len (car (RoutesV (car TrLst)))) + (ct-scheduler-nt-mv2 (cdr TrLst) prev + newntkstate))))))) +(defthm ct-scheduler-nt-mv2-equal + (equal (mv-nth 2 (ct-scheduler TrLst Scheduled ArrivedAcc prev measureAcc ntkstate)) + (append (rev measureAcc) (ct-scheduler-nt-mv2 TrLst prev ntkstate))) + :hints (("Goal" :in-theory (disable ct-test_routes)))) +(defthm ct-scheduler-nt-mv3-equal + (equal (mv-nth 3 (ct-scheduler TrLst Scheduler ArrivedAcc prev measureAcc ntkstate)) + ntkstate)) + +(defthm ntkstate-test-routes-mv0 + (equal (mv-nth 0 (ct-test_routes ntkstate v)) ntkstate)) +(defthm ntkstate-test-routes-car + (equal (car (ct-test_routes ntkstate v)) ntkstate)) + + + +;;--------------------------------------------------------------------- +;; +;; PROOF OF DECREASING MEASURE +;; +;;--------------------------------------------------------------------- +(defthm good_route-implies-smaller-routes + (mv-let (newntkstate r?) + (inst-test_routes ntkstate (car TrLst)) + (implies (test_prev_routes r? prev) + (< (car (ct-scheduler-nt-mv2 TrLst prev newntkstate)) + (car (RouteLengths-TrLst TrLst)))))) + +(defun elts-<= (x y) + (if (endp x) + (endp y) + (and (<= (car x) (car y)) + (natp (car x)) (natp (car y)) + (elts-<= (cdr x) (cdr y))))) + +(defthm elts-<=-implies-sum-<= + (implies (elts-<= x y) + (<= (sum-of-lst x) (sum-of-lst y)))) + +(defthm plus-< + (implies (and (< x1 y1) + (<= x y)) + (< (+ x1 x) + (+ y1 y)))) + +(defthm smaller-car-implies-smaller-sum + (implies (and (< (car x) (car y)) + (elts-<= x y)) + (< (sum-of-lst x) (sum-of-lst y)))) + +(defthm scheduled-routes-<=-original + (elts-<= (ct-scheduler-nt-mv2 TrLst prev ntkstate) + (RouteLengths-TrLst TrLst))) + +(defthm good-route-implies-smaller-measure + (mv-let (newntkstate r?) + (inst-test_routes ntkstate (car TrLst)) + (declare (ignore newntkstate)) + (implies (and (consp TrLst) + r?) + (< (sum-of-lst (ct-scheduler-nt-mv2 TrLst nil ntkstate)) + (sum-of-lst (RouteLengths-TrLst TrLst))))) + :hints (("Goal" :in-theory (disable get_buff orgv routesv + sum-of-lst good_route-implies-smaller-routes)))) + +(defthm good-route-possible-implies-smaller-measure + (implies (not (no-good-routes TrLst ntkstate)) + (< (sum-of-lst (ct-scheduler-nt-mv2 TrLst nil ntkstate)) + (sum-of-lst (RouteLengths-TrLst TrLst)))) + :hints (("Subgoal *1/3" :use (:instance good-route-implies-smaller-measure)) + ("Subgoal *1/2" :use (:instance good-route-implies-smaller-measure)) + +)) + +;;--------------------------------------------------------------------- +;; +;; PROOF OF GeNoC CONSTRAINTS +;; +;;--------------------------------------------------------------------- +;; 1/ proof that the measure decreases if assumptions are met +;; ----------------------------------- +(defthm ct-measure-decreases + (implies (and (ct-legal-measure measure trlst nodeset ntkstate order) + (ct-scheduling-assumptions trlst NodeSet ntkstate order)) + (O< (mv-nth 2 (ct-scheduling TrLst NodeSet ntkstate order)) + (acl2-count measure)))) + + +;;---------------------------------------------------------- + +;; 2/ we prove that the ids of the delayed and scheduled travels +;; are part of the initial travel list +;; ----------------------------------- +(in-theory (disable update-ntkstate)) +(defthm subsetp-scheduled-id-ct + (subsetp (V-ids (ct-scheduler-nt-car TrLst prev ntkstate)) + (V-ids TrLst))) +(defthm subsetp-delayed-id-ct + (subsetp (V-ids (ct-scheduler-nt-mv1 TrLst prev ntkstate)) + (V-ids TrLst))) +;------------------------------------------------------------------ + +;; 3/ we prove that the list of scheduled travels is a +;; valid travel list +;; -------------------------------------------------- + + +;; proof for the scheduled travels +;; ------------------------------- +(local + (defthm validfields-trlst-ct-sched + (implies (ValidFields-TrLst TrLst nodeset) + (ValidFields-TrLst (ct-scheduler-nt-car TrLst prev ntkstate) nodeset)))) + +(local + (defthm not-member-V-ids-ct-sched + (implies (not (member-equal e (V-ids TrLst))) + (not + (member-equal + e + (V-ids + (ct-scheduler-nt-car TrLst prev ntkstate))))))) + +(defthm no-duplicatesp-ct-sched + (implies (no-duplicatesp-equal (V-ids TrLst)) + (no-duplicatesp-equal + (V-ids (ct-scheduler-nt-car TrLst prev ntkstate))))) + +(defthm cons-v-ids + (equal (consp (v-ids TrLst)) + (consp TrLst))) + +(defthm TrLstp-scheduled-ct + (implies (TrLstp TrLst nodeset) + (TrLstp (ct-scheduler-nt-car TrLst prev ntkstate) nodeset))) + +;; proof for the delayed travels +;; ----------------------------- +(local + (defthm validfields-trlst-ct-del + (implies (ValidFields-TrLst TrLst nodeset) + (ValidFields-TrLst + (ct-scheduler-nt-mv1 TrLst prev ntkstate) nodeset)))) + +(local + (defthm not-member-V-ids-ct-del + (implies (not (member-equal e (V-ids TrLst))) + (not + (member-equal + e + (V-ids + (ct-scheduler-nt-mv1 TrLst prev ntkstate))))))) + +(local (defthm no-duplicatesp-ct-del + (implies (no-duplicatesp-equal (V-ids TrLst)) + (no-duplicatesp-equal + (V-ids (ct-scheduler-nt-mv1 TrLst prev ntkstate)))))) + +(defthm TrLstp-delayed-ct + (implies (TrLstp TrLst nodeset) + (TrLstp (ct-scheduler-nt-mv1 TrLst prev ntkstate) nodeset))) +;;-------------------------------------------------------------------- + + +;; 4/ correctness of the scheduled travels +;; ------------------------------------------------------ + +(defthm extract-sublst-cons + (implies (not (member-equal id Ids)) + (equal (extract-sublst (cons (list id org frm routes flit time) L) + Ids) + (extract-sublst L Ids)))) + + +(defthm test_prev_routes-member-equal + (mv-let (newntkstate r?) + (inst-good_route? ntkstate org dest routes) + (declare (ignore newntkstate)) + (implies r? + (member-equal r? routes)))) + +(defthm no-duplicatesp-equal-append + ;; to move to misc + (implies (no-duplicatesp-equal (append (list x) (v-ids y))) + (not (member-equal x (v-ids y))))) + + +(defthm ct-scheduled-correctness + (let ((arrived (ct-scheduler-nt-mv1 TrLst prev st))) + (implies (TrLstp TrLst nodeset) + (s/d-travel-correctness + arrived + (extract-sublst TrLst (V-ids arrived))))) + :hints (("GOAL" + :in-theory (disable len extract-sublst)) + ("Subgoal *1/9" + :in-theory (disable len ct-test_routes)) + ("Subgoal *1/5" + :in-theory (disable len ct-test_routes)))) + + + +;; 5/ We prove that Delayed is equal to filtering TrLst +;; according to the ids of Delayed +;; ---------------------------------------------------- +(defthm ct-delayed-correctness + (let ((traveling (ct-scheduler-nt-car TrLst prev st))) + (implies (TrLstp TrLst nodeset) + (subsetp + (V-ids traveling) (v-ids Trlst)))) + :hints (("GOAL" + :in-theory (disable len ct-test_routes) + :do-not '(eliminate-destructors))) + :rule-classes nil) + + +(defthm ct-delayed-correctness-org + (let ((traveling (ct-scheduler-nt-car TrLst prev st))) + (implies (TrLstp TrLst nodeset) + (subsetp (V-orgs traveling) (v-orgs Trlst)))) + :hints (("GOAL" + :in-theory (disable len ct-test_routes) + :do-not '(eliminate-destructors))) + :rule-classes nil) + + +(defthm ct-delayed-correctness-frm + (let ((traveling (ct-scheduler-nt-car TrLst prev st))) + (implies (TrLstp TrLst nodeset) + (subsetp + (V-frms traveling) (v-frms Trlst)))) + :hints (("GOAL" + :in-theory (disable len ct-test_routes) + :do-not '(eliminate-destructors))) + :rule-classes nil) + + +(defthm ct-delayed-correctness-destination + (let ((traveling (ct-scheduler-nt-car TrLst prev st))) + (implies (TrLstp TrLst nodeset) + (subsetp + (Tm-dests (totmissives traveling)) (Tm-dests (totmissives Trlst))))) + :hints (("GOAL" + :in-theory (disable len ct-test_routes) + :do-not '(eliminate-destructors)) + ("Subgoal *1/9" :in-theory (e/d (ct-test_routes) + (ct-chk_avail)))) + :rule-classes nil) + + +(defthm ct-delayed-correctness-destination-m + (let ((traveling (ct-scheduler-nt-car TrLst prev st))) + (implies (TrLstp TrLst nodeset) + (subsetp + (m-dests (tomissives(totmissives traveling))) + (m-dests (tomissives (totmissives Trlst)))))) + :hints (("GOAL" + :in-theory (disable len ct-test_routes ct-chk_avail) + :do-not '(eliminate-destructors)) + ("Subgoal *1/9" :in-theory (e/d (ct-test_routes) + (ct-chk_avail trlstp)))) + :rule-classes nil) + + +(defthm ct-delayed-correctness-ultime + (implies (Trlstp trlst nodeset) + (equal (tomissives (totmissives (ct-scheduler-nt-car TrLst prev st))) + (tomissives (totmissives (extract-sublst + trlst + (v-ids (ct-scheduler-nt-car TrLst prev st))))))) + :hints (("GOAL" + :in-theory (disable len ct-test_routes)) + ("Subgoal *1/9" :in-theory (e/d (ct-test_routes) + (ct-chk_avail))))) + +(defthm equal-tmids-vids-pkttraveling + (equal (v-ids (ct-scheduler-nt-car TrLst prev p)) + (tm-ids (totmissives (ct-scheduler-nt-car TrLst prev p)))) + :rule-classes nil) + + +(defthm equal-mids-tmids-vids-pkttraveling + (equal (v-ids (ct-scheduler-nt-car TrLst prev p)) + (m-ids (tomissives (totmissives (ct-scheduler-nt-car TrLst prev p))))) + :hints (("Goal" :in-theory (disable ct-test_routes))) + :rule-classes nil) + +(defthm ct-delayed-correctness-ultime-totmissives + (implies (Trlstp trlst nodeset) + (equal (tomissives + (totmissives (ct-scheduler-nt-car TrLst prev st))) + (tomissives + (totmissives + (extract-sublst trlst + (tm-ids (totmissives (ct-scheduler-nt-car TrLst prev st)))))))) + :hints (("GOAL" + :in-theory (disable trlstp len extract-sublst ct-test_routes)))) + +(defthm ct-delayed-correctness-ultime-totmissives-bis + (implies (Trlstp trlst nodeset) + (equal (tomissives (totmissives (ct-scheduler-nt-car TrLst prev p))) + (tomissives (extract-sublst (totmissives trlst) + (tm-ids (totmissives (ct-scheduler-nt-car TrLst prev p))))))) + :hints (("Goal" :do-not-induct t + :in-theory (disable trlstp len ct-test_routes)))) + + + +(defthm ct-delayed-correctness-ultime-totmissives-final + (implies (Trlstp trlst nodeset) + (equal (tomissives (totmissives (ct-scheduler-nt-car TrLst prev p))) + (extract-sublst (tomissives(totmissives trlst)) + (tm-ids (totmissives (ct-scheduler-nt-car TrLst prev p)))))) + + :hints (("Goal" :do-not-induct t + :use ((:instance ToTMissives-extract-sublst (L trslt) + (ids (v-ids (ct-scheduler-nt-car TrLst prev p)))) + (:instance ToMissives-extract-sublst (L (totmissives TRlst)) (ids (v-ids (ct-scheduler-nt-car TrLst prev p)))) + ) + :in-theory (disable extract-sublst v-ids default-car assoc-equal + nth-with-large-index nth-add1 + len ct-scheduler-nt-car trlstp)))) + +; ----------------------------------------------------------- + +;; ----------------------------------------------------------- +;; 6/ we prove that the ids of the delayed travels are distinct +;; from those of the scheduled travels +;; ------------------------------------------------------------ + +(defthm not-in-cons + (implies (and (not-in x y) + (not (member-equal e x))) + (not-in x (cons e y)))) + +(defthm not-in-v-ids-ct + (implies (trlstp trlst nodeset) + (not-in (v-ids (ct-scheduler-nt-car TrLst prev ntkstate)) + (v-ids (ct-scheduler-nt-mv1 TrLst prev ntkstate)))) + :hints (("Goal" :in-theory (disable ct-test_routes)))) +(defthm not-in-v-ids-ct2 + (implies (trlstp trlst nodeset) + (not-in (v-ids (ct-scheduler-nt-mv1 TrLst prev ntkstate)) + (v-ids (ct-scheduler-nt-car TrLst prev ntkstate)))) + :hints (("Goal" :in-theory (disable ct-test_routes)))) +(defthm subsetp-output-input + (subsetp (append (V-ids (ct-scheduler-nt-car TrLst prev st)) + (V-ids (ct-scheduler-nt-mv1 TrLst prev st ))) + (V-ids TrLst)) + :hints (("Goal" :in-theory (disable ct-test_routes)))) + +(defthm subsetp-input-output + (subsetp (V-ids TrLst) + (append (V-ids (ct-scheduler-nt-car TrLst prev st)) + (V-ids (ct-scheduler-nt-mv1 TrLst prev st)))) + :hints (("Goal" :in-theory (disable ct-test_routes)))) + + +(defthm input=output + (let ((out (ct-scheduling trlst NodeSet ntkstate order))) + (implies (true-listp trlst) + (trlst-equal (append (mv-nth 0 out) (mv-nth 1 out)) + trlst))) + :hints (("Goal" :use ((:instance subsetp-input-output (prev nil) (st ntkstate)) + (:instance subsetp-output-input (prev nil) (st ntkstate)))))) + +(defthm nil-trlstp + (trlstp nil nodeset)) + + +;; ----------------------------------------------------------- +;; Compliance to generic model +;; ------------------------------------------------------------ + +(definstance genericscheduling check-compliance-ct-scheduling + :functional-substitution + ((scheduling ct-scheduling) + (scheduling-assumptions ct-scheduling-assumptions) + (legal-measure ct-legal-measure) + (initial-measure ct-initial-measure) + (get_next_priority ct-get_next_priority) + (ValidParamsp 2DMesh-Validparamsp) + (NodeSetGenerator 2DMesh-NodeSetGenerator) + (loadbuffers inst-Loadbuffers) + (readbuffers inst-Readbuffers) + (StateGenerator inst-StateGenerator) + (ValidstateParamsp inst-ValidStateParamsp) + (req_trans inst-req_trans) + (process_req inst-process_req) + (chk_avail inst-chk_avail) + (good_route? inst-good_route?) + (test_routes inst-test_routes)) + :rule-classes nil + :otf-flg t + :hints (("goal" :do-not-induct t + :in-theory (disable trlstp)) +; Matt K.: The following subgoal hint was changed to "8.2'" from "8" because of +; the change after ACL2 Version 3.6.1 to speed up evaluation of calls of mv-let +; (which was a change to the way ACL2 translates mv-let expressions in theorems +; into internal form). It seems that this mv-let change may have affected the +; way make-event expansion is done here. + ("Subgoal 7.2'" ; changed after v4-3 from "Subgoal 8.2'", for tau system + :use ((:instance tomissives-extract-sublst (l (totmissives trlst)) + (ids (tm-ids (totmissives trlst)))) + (:instance totmissives-extract-sublst (l trlst) + (ids (v-ids trlst))) + (:instance extract-sublst-identity))))) + +(in-theory (enable update-ntkstate))#|ACL2s-ToDo-Line|# diff --git a/books/workshops/2009/verbeek-schmaltz/verbeek/instantiations/scheduling/circuit-switching-global/intersect.lisp b/books/workshops/2009/verbeek-schmaltz/verbeek/instantiations/scheduling/circuit-switching-global/intersect.lisp new file mode 100644 index 0000000..7f33753 --- /dev/null +++ b/books/workshops/2009/verbeek-schmaltz/verbeek/instantiations/scheduling/circuit-switching-global/intersect.lisp @@ -0,0 +1,134 @@ +#|$ACL2s-Preamble$; +;;------------------------------------------------------------------------- +;;------------------------------------------------------------------------- +;; +;; +;; Functional Specification and Validation of the Octagon Network on +;; Chip using the ACL2 Theorem Prover +;; +;; +;; Proof Script +;; +;; +;; Julien Schmaltz +;; Joseph Fourier University +;; 46, av. Felix Viallet 38031 Grenoble Cedex +;; FRANCE +;; Julien.Schmaltz@imag.fr +;; +;;------------------------------------------------------------------------- +;;------------------------------------------------------------------------- +;; we reuse the book developed for the study of the +;; Octagon and presented at the ACL2 workshop 2004 + +;; File: intersect.lisp +;; Contains definitions and lemmas about the intersection of routes +;; Link this concept to other functions, e.g. no-duplicatesp +(begin-book);$ACL2s-Preamble$|# + +(in-package "ACL2") +(include-book "data-structures/list-defuns" :dir :system) +(include-book "data-structures/list-defthms" :dir :system) + + +;;------------------------------------------------------------- +;; EMPTY INTERSECTION +;;------------------------------------------------------------ +(defun no_intersectp (l1 l2) + ;; returns t if every element of l1 is not in l2 + ;; i.e. if l1 and l2 have an empty intersection + (if (endp l1) + t + (and (not (member (car l1) l2)) + (no_intersectp (cdr l1) l2))))#|ACL2s-ToDo-Line|# + + +;; we prove some properties of this predicate +(defthm commutativity_no_intersectp + ;; it is commutative + (equal (no_intersectp l1 l2) + (no_intersectp l2 l1))) + +(defthm no_intersectp_append + ;; we link this concept with APPEND + (equal (no_intersectp l1 (append l2 l3)) + (and (no_intersectp l1 l2) + (no_intersectp l1 l3)))) + +(defthm no_intersectp_append-1 + ;; it should be better to have some kind of normalization + ;; but the proof of rules to go to the normal form is + ;; not automatic in ACL2, but this rule is automatic. + (equal (no_intersectp (append l1 l2) l3) + (and (no_intersectp l1 l3) + (no_intersectp l2 l3)))) + +#| + +;;--------------------------------------------------------- +;; NODE COLLECTION +;;-------------------------------------------------------- + (i-am-here) +(defun grab_nodes (travel_list) + ;; collects all the nodes of all the routes of the travel list + ;; Pb: in the new version of GeNoC there are several routes + ;; not just one :-) + (if (endp travel_list) + nil + (append (RoutesV (car travel_list)) + (grab_nodes (cdr travel_list))))) + +(defthm no-duplicatesp-append + (implies (and (no-duplicatesp l1) + (no-duplicatesp l2) + (no_intersectp l1 l2)) + (no-duplicatesp (append l1 l2)))) + +(defthm no-duplicatesp-append-nil + (implies (no-duplicatesp l) + (no-duplicatesp (append l nil)))) + +(defun all_no_intersectp (route travel_list) + ;; returns t if route does not intersect with all the routes + ;; of the travel list + (if (endp travel_list) + t + (and (no_intersectp route (cdr (car travel_list))) + (all_no_intersectp route (cdr travel_list))))) + +(defthm all_no_intersectp_append + ;; we link this concept with append + (equal (all_no_intersectp l1 (append l2 l3)) + (and (all_no_intersectp l1 l2) + (all_no_intersectp l1 l3)))) + + +(defthm all_no_intersectp_grab_nodes + ;; we also link it with grab_nodes + (equal (all_no_intersectp r tl) + (no_intersectp r (grab_nodes tl)))) + +(defun all_no_intersectp_routep (travel_list) + ;; returns t if every route of the travel list has no intersection with + ;; every other route + (if (endp (cdr travel_list)) + t + (and (all_no_intersectp (cdr (car travel_list)) + (cdr travel_list)) + (all_no_intersectp_routep (cdr travel_list))))) +|# + +#| + +(defthm all_no_duplicates_and_all_no_intersectp_route_=>_no_dupli_grab_nodes + ;; we prove that this concept and if every route has no duplicate, + ;; then grab_nodes of this travel list has no duplicate + (implies (and (all_no_intersectp_routep l) + (all_no_duplicatesp l)) + (no-duplicatesp (grab_nodes l))) +; [Removed by Matt K. to handle changes to member, assoc, etc. after ACL2 4.2.] +; :hints (("GOAL" +; :in-theory (disable NO-DUPLICATESP->NO-DUPLICATESP-EQUAL))) + ) +|# + diff --git a/books/workshops/2009/verbeek-schmaltz/verbeek/instantiations/simulation/simple/simple.lisp b/books/workshops/2009/verbeek-schmaltz/verbeek/instantiations/simulation/simple/simple.lisp new file mode 100644 index 0000000..a77a8c5 --- /dev/null +++ b/books/workshops/2009/verbeek-schmaltz/verbeek/instantiations/simulation/simple/simple.lisp @@ -0,0 +1,26 @@ +#|$ACL2s-Preamble$; +(begin-book);$ACL2s-Preamble$|# + +(in-package "ACL2") + + +(include-book "../../../generic-modules/GeNoC-simulation") +(set-state-ok t) +(set-ignore-ok t) + +(defun simple-treat-state-entry (coor contents) + (cons coor contents)) + +(defun simple-extract-simulation (ntkstate) + (if (endp ntkstate) + nil + (append (simple-treat-state-entry (cadaar ntkstate) (cdadr (car ntkstate))) + (simple-extract-simulation (cdr ntkstate))))) + + +(definstance Genericsimulationextraction simple-simulation-compliance + ;; ACL2 proves automatically that our spidergon nodeset is a valid instance + ;; of the generic nodeset of GeNoC. + :functional-substitution + ((extract-simulation simple-extract-simulation))) + diff --git a/books/workshops/2009/verbeek-schmaltz/verbeek/instantiations/synchronization/circuit-global/circuit.lisp b/books/workshops/2009/verbeek-schmaltz/verbeek/instantiations/synchronization/circuit-global/circuit.lisp new file mode 100644 index 0000000..b8fbdef --- /dev/null +++ b/books/workshops/2009/verbeek-schmaltz/verbeek/instantiations/synchronization/circuit-global/circuit.lisp @@ -0,0 +1,89 @@ +#|$ACL2s-Preamble$; +(begin-book);$ACL2s-Preamble$|# + +(in-package "ACL2") + + +(include-book "../../../generic-modules/GeNoC-synchronization") +(include-book "../../ntkstate/simple/simple") + + +(defun has-empty-buffers (route ntkstate) + (if (endp route) + t + (if (has-empty-buffer (inst-readbuffers (car route) ntkstate)) + (has-empty-buffers (cdr route) ntkstate) + nil))) + +;; This function checks if all hops in route are free +;; or not in the current state of the network. +;; +;; The function also verifies the route +;; to prove the obligation chk_avail_obligation-for-scheduling. +;; +(defun ct-chk_avail (ntkstate org dest route) + (and (has-empty-buffers (cdr route) ntkstate) + (not (equal org (car (last (cdr route))))) + (equal dest (car (last (cdr route)))) + (no-consecutive-equals route) + (no-hops-equal-to-dest route dest) + (>= (len route) 2))) + +;; finds a possible route in routes +(defun ct-good_route? (ntkstate org dest routes) + (if (endp routes) + (mv ntkstate nil) + (if (ct-chk_avail ntkstate org dest (car routes)) + (mv ntkstate (car routes)) + ; for now, routes has only one route + (mv ntkstate nil)))) + ;(ct-good_route? ntkstate org dest (cdr routes))))) + +;; the top function to check the route +(defun ct-test_routes (ntkstate tr) + (let* ((routes (routesv tr)) + (dest (car (last (car routes)))) + (org (orgv tr))) + (mv-let (newntkstate r?) + (ct-good_route? ntkstate org dest routes) + (mv newntkstate r?)))) + +(defun ct-req_trans (st) + st) +(defun ct-process_req (st dest) + (declare (ignore st dest)) + t) +(defun ct-check_ack (st cur dest) + (declare (ignore st cur dest)) + t) + +;------------------------------------- +; the instantiations used in this file +;------------------------------------ +(defmacro inst-chk_avail (ntkstate org dest route) + (list 'ct-chk_avail ntkstate org dest route)) +(defmacro inst-good_route? (ntkstate org dest routes) + (list 'ct-good_route? ntkstate org dest routes)) +(defmacro inst-test_routes (ntkstate tr) + (list 'ct-test_routes ntkstate tr)) +(defmacro inst-req_trans (st) + (list 'ct-req_trans st)) +(defmacro inst-process_trans (st dest) + (list 'ct-process_trans st dest)) +(defmacro inst-check_ack (st cur dest) + (list 'ct-check_ack st cur dest)) + + +(definstance genericsynchronisation check-compliance-ct-synchronization + :functional-substitution + ((req_trans ct-req_trans) + (process_req ct-process_req) + (chk_avail ct-chk_avail) + (good_route? ct-good_route?) + (test_routes ct-test_routes) + (check_ack ct-check_ack) + (loadbuffers inst-Loadbuffers) + (readbuffers inst-Readbuffers) + (StateGenerator inst-StateGenerator) + (ValidstateParamsp inst-ValidStateParamsp)) + :rule-classes nil)#|ACL2s-ToDo-Line|# |