packages feed

tamarin-prover 0.4.1.0 → 0.6.0.0

raw patch · 83 files changed

+11873/−10167 lines, 83 filesdep ~hamletdep ~lifted-basedep ~tamarin-prover-term

Dependency ranges changed: hamlet, lifted-base, tamarin-prover-term, tamarin-prover-utils, threads, wai, warp, yesod-core, yesod-json, yesod-static

Files

data/CHANGES view
@@ -1,3 +1,33 @@+* 0.6.0.0+   - open-sourced the code: https://github.com/tamarin-prover/tamarin-prover++   - core prover:+       - Normal form construction rules now log their conclusion as a+         KU-action. This allows to refer to the conclusions of construction+         rules in security properties. We exploit this to formalize typing+         invariants, which describe the structure of the instantiation of+         message variables precisely enough for getting rid of+         Chain-constraints starting from these message variables.++       - Reimplemented the constraint solver using a modified set of+         constraint rules that also supports attack extraction, when using+         inductive strengthening of security properties. As a nice side effect+         this allowed us to get rid of implicit construction dependencies.+         Moreover, the new prover's code is extensively documented, thereby+         facilitating further extensions.++       - Removed preliminary support for typing invariants based on+         Ded-actions and the deducible-before-atom (--|).++       - See the MANUAL for an explanation of the theory that we changed with+         respect to our CSF'12 paper.++   - GUI:+       - action atoms are also displayed graphically+       - the autoprover now respect all flags from the command line; e.g.,+         using `tamarin-prover interactive --bound=7` will give you a+         bounded-depth prover in the interactive GUI.+ * 0.4.1.0    - core prover:        - detect maude errors earlier@@ -31,7 +61,7 @@        - intruder rule generation works now correctly again  * 0.1.1.0 Bug-fix release-  +   - fixed: automatically create output directory, if it does not exist   - fixed: wrong flags given in help message for starting interactive mode
data/doc/MANUAL view
@@ -1,7 +1,7 @@ User manual for the Tamarin prover ================================== -Date:    2012/04/11+Date:    2012/06/04 Authors: Simon Meier <iridcode@gmail.com>,          Benedikt Schmidt <beschmi@gmail.com> @@ -43,15 +43,15 @@   1. Copy the example protocol that is most similar to the one your are      modeling. Let us assume that this copy is named 'myproto.spthy'. -  2. Modify the protocol a bit and call 'tamarin-prover myproto.spthy' to-     ensure that it still parses and all well-formedness checks pass. This-     way you get immediate feedback on your changes. Moreover, you can see the-     expansions of syntactic sugar like the built-in signatures for hashing or-     asymmetric encryption.+  2. Modify the protocol piece by piece and call 'tamarin-prover+     myproto.spthy' to ensure that it still parses and all well-formedness+     checks pass. This way you get immediate feedback on your changes.+     Moreover, you can see the expansions of syntactic sugar like the built-in+     signatures for hashing or asymmetric encryption.    3. Once you are satisfied with your model, check if the automated prover      succeeds in analyzing your protocol by calling-     +        'tamarin-prover myproto.spthy --prove'    4. If the Tamarin prover does not terminate, then you can either bound the@@ -60,8 +60,12 @@         'tamarin-prover interactive myproto.spthy' -     and try to construct the proof interactively.+     and try to construct the proof interactively. If you want to bound the+     proof depth of the autoprover in interactive mode, you can call the+     Tamarin prover as follows. +       'tamarin-prover interactive myproto.spthy --bound=7'+      Note that you can also use the GUI to sanity check your model. Just go      through the message theory and check that it really models what you      intent to model. Moreover, the precomputed case distinctions, described@@ -79,14 +83,27 @@    http://www.infsec.ethz.ch/research/software#TAMARIN -The implementation exploits a slightly refined theory, which allows to store-multiple constraint reduction steps in the form of *precomputed case-distinctions* and which allows to delay the enumeration of the finite variants-of multiset rewriting rules using an *equation store*. We explain these two-components below. We also give a sneak-peek preview on the theory we have-developed for dealing with loop-invariants.+The implementation exploits a slightly more restricted definition of normal+dependency graphs and adapted versions of the constraint solving rules that+also allow security properties to refer to the conclusions of normal+construction rules. A technical report documenting this version of the+constraint solver is under preparation. From a usage perspective, the changes+are minor and explained below in the sections on+`Induction` and `Typing Invariants over the Extended Traces`. +Moreover, we added a constraint solving rule that allows to reason about+protocols that make use of exclusive access to linear facts. A typical example+is 'loops/Minimal_Create_Use_Destroy.spthy'. The corresponding constraint+reduction rule is explained below. +Apart from the above changes to the constraint solving rules, we also refined+the theory in two ways that allow to share work between different constraint+reduction steps. First, we store multiple constraint reduction steps in the+form of *precomputed case distinctions*. Second, we delay the enumeration of+the finite variants of multiset rewriting rules using an *equation store*. We+explain both of these refinements below.++ Precomputed Case Distinctions ----------------------------- @@ -104,6 +121,98 @@ constructor of a message.  +Inductive Strengthening+-----------------------++The normal form conditions that we impose on dependency graphs can be seen as+a strong invariant on security protocol execution. As we have shown in our+case studies many security properties follow from these normal form+conditions. For some protocols, we must however strengthen security properties+before being able to prove them using our backwards reasoning technique. This+strengthening works by transforming the security property according to the+induction scheme associated with the set of traces of a protocol. Intuitively,+this strengthening amounts to searching for traces that violate the security+property, but do not contain any prefix that violates the security property.+Stated differently, we focus on first violations of security properties with+respect to the prefix-order on traces.++Properties that should be proven using induction can be marked with the+attribute [use_induction]. In the interactive GUI, one can just select+`induction` as a proof method provided the constraint system contains just one+guarded trace property.++For examples of protocols where inductive strengthening is required for a+successful proof, see the directories `examples/loops` and+`examples/related_work`.+++Typing Invariants over the Extended Traces+------------------------------------------++Note that every protocol communicating via the public network/adversary+implicitly contains loops. The adversary may send messages received from a+later step of one instance a role to an earlier step of another instance of+the same role. These loops manifest themselves during backwards reasoning as+infinite proof branches. For trivial loops where all messages are also+received as plain-text, we can prune these branches using the constraint+reduction rule N6. To prune more complicated loops, e.g., loops stemming from+receiving an encrypted message and sending out some of its contents, we need+so called typing invariants.++A typing invariant specifies the possible instantiations of a message variable+sent to the adversary. We describe these instantiations by relating an action+logging the instantiation in the rule sending the variable to actions logging+the possible instantiations in the rules sending the contents of this+variable. See the 'classic/NSLPK3.spthy' file for an example of a typing+invariant.++To enable the specification of the case that the intruder constructed the+message that a variable is instantiated with, we changed every construction+rule such that a KU-action logs the rule's conclusion. Properties referring to+this KU-actions can only be evaluated over the traces of normal dependency+graphs of a protocol. We call these traces the 'extended traces of a protocol'.+Note that we cannot transfer the validity of properties over extended traces+to the validity of these properties over standard traces stemming from the+multiset rewriting semantics. However, we can use these properties over+extended traces as lemmas during the proof of a property over standard traces+using the lemma attribute [reuse] or [typing].++The goal of typing invariants is to ensure that all chain-constraints are+solved during the precomputation of the case distinctions. We use a two-step+process to achieve this. We first precompute the so-called *untyped case+distinctions* without the assumption of the validity of any typing invariant.+These untyped precomputed case are used during the proof of a typing+invariant. We then use the typing invariants to refine the untyped case+distinctions to typed case distinctions. They are used during the proofs of+properties other than typing invariants.++In the input file, all typing invariants are marked with the [typing]+attribute. In the GUI, you can inspect both the untyped and typed precomputed+case distinctions. A typing invariant achieves its goal, if the typed+precomputed case distinctions are marked with "all chains solved".+++Reasoning about Exclusivity+---------------------------++We say that a fact symbol 'f' has `unique instances with respect to a security+protocol 'P', if all instances of 'f' occur with cardinality <= 1 in all+reachable states of 'P'. As computing the set of fact symbols with unique+instances with respect to a security protocol 'P' is undecidable, we use a+simple under-approximation to this set. We gather all linear fact symbols that+occur in all conclusions either as a copy of themselves or a copy of the term+of a Fr-fact.++For facts with unique instances, we can use a further constraint reduction+rule. This rule states that it is impossible that there is a node 'i' with a+premise with a unique fact instance and an edge with the same fact instance+from a node 'j' to a node 'k' such that 'j' < 'i' < 'k'.++Together with inductive strengthening, this simple construction suffices for+many protocols to reason about their exclusive use of a linear fact symbol to+model locked access to a resource.++ Equation Store -------------- @@ -141,31 +250,7 @@       )  -(Loop) Invariants------------------ -The normal form conditions that we impose on dependency graphs can be seen as-a strong invariant on security protocol execution. As we have shown in our-case studies many security properties follow from these normal form-conditions. However, for some protocols additional invariants are necessary to-prove their security properties.--We can formalize such invariants by specifying them as trace formulas. We can-prove them using the induction scheme associated to the traces of a protocol.-We using this induction scheme in the form of a trace formula conversion that-converts a guarded trace formula \phi to a semantically equivalent formula-\phi_{inductive}. This formula \phi_{inductive} is again a guarded trace-formula. It is easier to prove because it contains the induction hypothesis in-a weakened form. Semantically, the formula \phi_{inductive} states that we are-looking for counter-examples that are minimal with respect to the prefix-order-on traces.--You can apply induction by clicking on the 'induction' proof method in the-GUI or adding the [inductive] attribute to a lemma. An example protocol whose-proof require induction is given in 'examples/stable/InvariantsExample.spthy'.--- Security Protocol Theories ========================== @@ -180,7 +265,7 @@ is processed by Tamarin. We recommend first reading the 'Tutorial.spthy' example before delving into the following section. -Comments are C-style: +Comments are C-style:      /* for a multi-line comment */     // for a line-comment@@ -209,15 +294,15 @@ it to parse terms containing exponentiations, e.g.,  g ^ x.      built_in       := 'builtins' ':' built_ins list-    built_ins      := 'diffie-hellman' -                    | 'hashing' | 'symmetric-encryption' -                    | 'asymmetric-encryption' | 'signing' +    built_ins      := 'diffie-hellman'+                    | 'hashing' | 'symmetric-encryption'+                    | 'asymmetric-encryption' | 'signing'  Multiset rewriting rules are specified as follows. The protocol corresponding to a security protocol theory is the set of all multiset rewriting rules specified in the body of the theory. -    rule := 'rule' ident ':' +    rule := 'rule' ident ':'             [let_block]             '[' facts ']' ( '-->' | '--[' facts ']->') '[' facts ']' @@ -238,10 +323,10 @@ security protocol theory. You can change this using the 'exists-trace' trace quantifier. -    lemma := 'lemma' ident [lemma_attrs] ':' -             [trace_quantifier] +    lemma := 'lemma' ident [lemma_attrs] ':'+             [trace_quantifier]              '"' formula '"'-    lemma_attrs := '[' ('typing' | 'reuse' | 'inductive') ']'+    lemma_attrs := '[' ('typing' | 'reuse' | 'use_induction') ']'     trace_quantifier := 'all-traces' | 'exists-trace'  @@ -289,9 +374,11 @@ Facts do not have to be defined up-front. This will probably change once we implement user-defined sorts. Facts prefixed with '!' are persistent facts. All other facts are linear. There are six reserved fact symbols: In, Out, KU,-KD, K, and Ded. KU and KD facts are used for construction and deconstruction-rules. The 'Ded' fact logs the messages deduced by construction rules. See the-InductionInvariant.spthy example for more information.+KD, and K. KU and KD facts are used for construction and deconstruction+rules. KU-facts also log the messages deduced by construction rules. Note that+KU-facts have arity 2. Their first argument is used to track the+exponentiation tags. See the 'loops/Crypto_API_Simple.spthy' example for more+information.      facts := fact list     fact := ['!'] ident '(' multterm list ')'@@ -329,8 +416,8 @@ ==================  The Tamarin prover is under active development. We are grateful to receive-bug-reports. If you consider building on top of Tamarin, then you might-consider integrating your idea into the main source repository. Please feel-free to contact us such that we can discuss the next steps towards fully-verified systems :-)+bug-reports at 'https://github.com/tamarin-prover/tamarin-prover/issues'. If+you consider building on top of Tamarin, then you might consider integrating+your idea into the main source repository. Please feel free to contact us such+that we can discuss the next steps towards fully verified systems :-)
+ data/examples/Tutorial.spthy view
@@ -0,0 +1,407 @@+/*+Tutorial for the Tamarin prover for security protocol analysis+==============================================================++Authors: 	Simon Meier, Benedikt Schmidt+Date: 	        April 2012+++Introduction+------------++This user guide assumes that you have a copy of our CSF'12 paper on+"Automated Analysis of Diffie-Hellman Protocols and Advanced Security+Properties", whose extended version is available from+http://www.infsec.ethz.ch/research/software#TAMARIN.++The input files for the Tamarin prover have the extension .spthy, which is+short for 'security protocol theory'. A security protocol theory specifies++  1. the signature and equational theory to use for the message algebra,+  2. the set of set of multiset rewriting rules modeling the protocol and+     the adversary capabilities, and+  3. the guarded trace properties whose validity we wish to check for this+     set of multiset rewriting rules.++We explain each of these parts where they occur in the following security+protocol theory. Before we start, a few notes on the syntax.+As you probably noticed, comments are C-style. All identifiers are+case-sensitive. The parser is layout-insensitive, i.e., your are free to use+whitespace as it suits you. We provide a complete specification of the input+syntax in the reference MANUAL.+++Modeling a security protocol+----------------------------++Every security protocol theory starts with a header of the following form.+*/++theory Tutorial+begin++/*+Obviously, you can replace 'Tutorial' with any name you like to give your+theory. After 'begin', you can declare function symbols, equations that they+must satisfy, multiset rewriting rules, and lemmas specifying security+properties. Moreover, you can also insert formal comments, to structure your+theory. We give examples of each of these elements while modeling the+a simple protocol.++In this protocol, a client C generates a fresh symmetric key 'k', encrypts it+with the public key of a server 'S' and sends it to 'S'. The server confirms+the receipt of the key by sending back its hash to the client. In+Alice-and-Bob notation the protocol would read as follows.++  C -> S: aenc{k}pk(S)+  C <- S: h(k)++This protocol is artificial and it satisfies only very weak security+guarantees. We can prove that from the perspective of the client, the freshly+generated key is secret provided that the server is uncompromised.++We model this protocol in three steps. First, we declare the function symbols+and the equations defining them. Then, we introduce multiset rewriting rules+modeling a public key infrastructure (PKI) and the protocol. Finally, we state+the expected security properties.+++Function Signature and Equational Theory+----------------------------------------++We model hashing using the unary function 'h'.+We model asymmetric encryption by declaring+  a binary function 'aenc' denoting the encryption algorithm,+  a binary function 'adec' denoting the decryption algorithm, and+  a unary function 'pk' denoting the algorithm computing a public+  key from a private key.+*/++functions: h/1, aenc/2, adec/2, pk/1+equations: adec(aenc(m, pk(k)), k) = m++/*+The above equation models the interaction between calls to these three+algorithms. All such user-specified  equations must be subterm-convergent+rewriting rules, when oriented from left to right. This means that the+right-hand-side must be a subterm of the left-hand-side or a nullary+function symbol.++Certain equational theories are used very often when modeling cryptographic+messages. We therefore provide builtins definitions for them. The above theory+could also be enabled using the declaration++  builtins: hashing, asymmetric-encryption++We support the following builtins theories:++  diffie-hellman, signing, asymmetric-encryption, symmetric-encryption,+  hashing++Note that the theory for hashing only introduces the function symbol 'h/1'+and contains no equations.+Apart from 'diffie-hellman', all of these theories are subterm-convergent and+can therefore also be declared directly, as above. You can inspect their+definitions by uncommenting the following two line-comments and calling++  tamarin-prover Tutorial.spthy++*/++// builtins: diffie-hellman, signing, asymmetric-encryption, symmetric-encryption,+//          hashing++/*+The call 'tamarin-prover Tutorial.spthy' parses the Tutorial.spthy file,+computes the variants of the multiset rewriting rules, checks their+wellformedness (explained below), and pretty-prints the theory. The+declaration of the signature and the equations can be found at the top of the+pretty-printed theory.++Proving all lemmas contained in the theory is as simple as adding the+flag '--prove' to the call; i.e.,++  tamarin-prover Tutorial.spthy --prove++However, let's not go there yet. We first have to model the PKI and our+protocol.+++Modeling the Public Key Infrastructure+--------------------------------------+*/++// Registering a public key+rule Register_pk:+  [ Fr(~ltk) ]+  -->+  [ !Ltk($A, ~ltk), !Pk($A, pk(~ltk)) ]++/* The above rule models registering a public key. It makes use of the+   following syntax.++   Facts always start with an upper-case letter and do not have to declared.+   If their name is prefixed with an exclamation mark '!', then they are+   persistent. Otherwise, they are linear. Note that you must use every fact+   name consistently; i.e., you must always use it with the same arity, casing,+   and multiplicity. Otherwise, the tamarin prover complains that the theory+   is not wellformed.++   The 'Fr' fact is a builtins fact. It denotes a freshly generated fresh name.+   See the paper for details.++   We denote the sort of variables using prefixes:++     ~x  denotes  x:fresh+     $x  denotes  x:pub+     #i  denotes  i:temp+     i   denotes  i:msg++     'c' denotes a public name 'c \in PN'; i.e., a fixed, global constant++   Thus, the above rule can be read as follows. First, freshly generate a+   fresh name 'ltk', the new private key and nondeterministically choose a+   public name 'A', the agent for which we are generating the key-pair.+   Then, generate the persistent fact !Ltk($A, ~ltk), which denotes the+   association between agent 'A' and its private key 'ltk, and generate the+   persistent fact !Pk($A, pk(~ltk)), which denotes the association between the+   agent 'A' and its public key 'pk(~ltk)'.++   We allow the adversary to retrieve any public key using the following rule.+   Intuitively, it just reads a public-key database entry and sends the public+   key to the network using the builtins fact 'Out' denoting a message sent to+   the network. See our paper for more information.+*/++rule Get_pk:+  [ !Pk(A, pk) ]+  -->+  [ Out(pk) ]++/*+   We model the dynamic compromise of long-term private keys using the following+   rule. Intuitively, it reads a private-key database entry and sends it to+   the adversary. This rule has an observable 'LtkReveal' action stating that+   the long-term key of agent 'A' was compromised. We will use this action in+   the security property below to determine which agents are compromised.+*/++rule Reveal_ltk:+    [ !Ltk(A, ltk) ]+  --[ LtkReveal(A) ]->+    [ Out(ltk) ]+++/*++Modeling the protocol+----------------------++Recall that we want to model the following protocol.++  C -> S: aenc{k}pk(S)+  C <- S: h(k)++We model it use the following three rules.+*/++// Start a new thread executing the client role, choosing the server+// non-deterministically.+rule Client_1:+    [ Fr(~k)         // choose fresh key+    , !Pk($S, pkS)   // lookup public-key of server+    ]+  -->+    [ Client_1( $S, ~k )       // Store server and key for next step of thread+    , Out( aenc{'1', ~k}pkS )  // Send the encrypted session key to the server+                               // We add the tag '1' to the request to allow+                               // the server to check whether the decryption+                               // was successful.+    ]++rule Client_2:+    [ Client_1(S, k)   // Retrieve server and session key from previous step+    , In( h(k) )       // Receive hashed session key from network+    ]+  --[ SessKeyC( S, k ) ]-> // State that the session key 'k'+    []                     // was setup with server 'S'++// A server thread answering in one-step to a session-key setup request from+// some client.+rule Serv_1:+    [ !Ltk($S, ~ltkS)                          // lookup the private-key+    , In( request )                            // receive a request+    ]+  --[ Eq(fst(adec(request, ~ltkS)), '1')+    , AnswerRequest($S, snd(adec(request, ~ltkS)))   // Explanation below+    ]->+    [ Out( h(snd(adec(request, ~ltkS))) ) ]    // Return the hash of the+                                               // decrypted request.++/* Above, we model all applications of cryptographic algorithms explicitly.+   Call 'tamarin-prover Tutorial.spthy' to inspect the finite variants of the+   Serv_1 rule, which list all possible interactions of the destructors used.+   In our proof search, we will consider all these interactions.++   We also model that the server explicitly checks that the first component of+   the request is equal to '1'. We  model this by logging the claimed equality+   and then adapting the security property such that it only considers traces+   where all 'Eq' actions occur with two equal arguments. Note that 'Eq' is NO+   builtin fact. Guarded trace properties are strong enough to formalize this+   requirement without builtin support. Note that inequalities can be modeled+   analogously.++   We log the session-key setup requests received by servers to allow+   formalizing the authentication property for the client.+++Modeling the security properties+--------------------------------++The syntax for specifying security properties uses++  All      for universal quantification, temporal variables are prefixed with #+  Ex       for existential quantification, temporal variables are prefixed with #+  ==>      for implication+  &        for conjunction+  |        for disjunction+  not      for  negation++  f @ i    for action constraints, the sort prefix for the temporal variable 'i'+           is optional++  i < j    for temporal ordering, the sort prefix for the temporal variables 'i'+           adn 'j' is optional++  #i = #j  for an equality between temporal variables 'i' and 'j'+  x = y    for an equality between message variables 'x' and 'y'++Note that apart from public names (delimited using single-quotes), no terms+may occur in guarded trace properties. Moreover, all variables must be+guarded. The error message for an unguarded variable is currently not very+good.++For universally quantified variables, one has to check that they all occur in+an action constraint right after the quantifier and that the outermost logical operator+inside the quantifier is an implication.+For existentially quantified variables, one has to check that they all occur in+an action constraint right after the quantifier and that the outermost logical+operator inside the quantifier is a conjunction.+Note also that currently the precedence of the logical connectives is not+specified. We therefore recommend to use parentheses, when in doubt.+++The following two properties should be self-explanatory.+*/++lemma Client_session_key_secrecy:+  "  /* For all traces, where all equality checks succeed, */+    (All x y #i. Eq(x,y) @ i ==> x = y)+  ==>+    /* it cannot be that a  */+    not(+      Ex S k #i #j.+        /* client setup a session key 'k' with a server'S' */+        SessKeyC(S, k) @ #i+        /* and the adversary knows 'k' */+      & K(k) @ #j+        /* without having performed a long-term key reveal on 'S'. */+      & not(Ex #r. LtkReveal(S) @ r)+    )+  "+++/* FIXME: Uncomment+lemma Client_auth:+  " /* For all traces, where all equality checks succeed, */+    (All x y #i. Eq(x,y) @ i ==> x = y)+  ==>+    /* for all session keys 'k' setup by clients with a server 'S' */+    ( All S k #i.  SessKeyC(S, k) @ #i+       ==>+         /* there is a server that answered the request */+       ( (Ex #a. AnswerRequest(S, k) @ a)+         /* or the intruder performed a long-term key reveal on 'S'+            before the key was setup. */+       | (Ex #r. LtkReveal(S) @ r & r < i)+       )+    )+  "+*/++/*+  You can verify them by calling++    tamarin-prover --prove Tutorial.spthy++  This will first output some logging from the constraint solver and then the+  Tutorial security protocol theory with the lemmas and their attached+  (dis)proofs.++  Finding attacks is very useful, to check that a security property is not+  trivial due to too strong preconditions. The following property must not be+  provable, as otherwise there would be no possibility to setup a session key+  with a honest sever.++  We can check for the existence of a trace using the 'exists-trace'+  quantifier in front of the trace formula. When modeling protocols such+  existence proof are very useful sanity checks.+*/+/* FIXME: Uncomment+lemma Client_session_key_honest_setup:+  exists-trace+  " (All x y #i. Eq(x,y) @ i ==> x = y)+  & (+      Ex S k #i.+        SessKeyC(S, k) @ #i+      & not(Ex #r. LtkReveal(S) @ r)+    )+  "+*/++/*++Interactive proof visualization and construction+------------------------------------------------++Just call++  tamarin-prover interactive Tutorial.spthy++This will start a web-server that loads all security protocol theories in the+same directory as Tutorial.spthy. Point your browser to++  http://localhost:3001++and explore the the Tutorial theory interactively by clicking on the+'Tutorial' entry in the table of loaded theories. You can prove a lemma+interactively by clicking on the available proof methods (corresponding to+applications of constraint reduction rules) or by calling the 'autoprover' by+right-clicking on a node in the theory overview. Note that that the proof+methods in the GUI are sorted according to our heuristic. Always selecting the+first proof method will result in the same proof as the ones constructed by+the 'autoprover' and '--prove'.+++Conclusion+----------++By now, you should have enough knowledge to understand the case studies from+our CSF'12 paper. Recall that you can find them in the directory listed at the+bottom of the help message, when calling 'tamarin-prover' without any+arguments. Note that Tamarin also outputs the path to the reference MANUAL+specifying and explaining the grammar of security protocol theories and giving+some additional hints on additional theory exploited by Tamarin.  If you have+further questions, please do not hesitate to contact either++  Benedikt Schmidt    benedikt.schmidt@inf.ethz.ch+  Simon Meier         simon.meier@inf.ethz.ch+  Cas Cremers         cas.cremers@inf.ethz.ch+++BTW, every security protocol theory must be delimited with 'end'.++             (-: HAPPY PROVING :-)+*/++end
+ data/examples/classic/NSLPK3.spthy view
@@ -0,0 +1,157 @@+theory NSLPK3+begin++builtins: asymmetric-encryption++/*+   Protocol:    The classic three message version of the+                Needham-Schroeder-Lowe Public Key Protocol+   Modeler:     Simon Meier+   Date:        June 2012+   Source:      Modeled after the description by Paulson in+                Isabelle/HOL/Auth/NS_Public.thy.++   Status:      working++   Note that we are using explicit global constants for discerning the+   different encryption instead of the implicit typing.+ */+++// Public key infrastructure+rule Register_pk:+  [ Fr(~ltkA) ]+  -->+  [ !Ltk($A, ~ltkA), !Pk($A, pk(~ltkA)), Out(pk(~ltkA)) ]++rule Reveal_ltk:+  [ !Ltk(A, ltkA) ] --[ RevLtk(A)    ]-> [ Out(ltkA) ]+++/* We formalize the following protocol++  protocol NSLPK3 {+    1. I -> R: {'1',ni,I}pk(R)+    2. I <- R: {'2',ni,nr,R}pk(I)+    3. I -> R: {'3',nr}pk(R)+  }+*/++rule I_1:+  let m1 = aenc{'1', ~ni, $I}pkR+  in+    [ Fr(~ni)+    , !Pk($R, pkR)+    ]+  --[ OUT_I_1(m1)+    ]->+    [ Out( m1 )+    , St_I_1($I, $R, ~ni)+    ]++rule R_1:+  let m1 = aenc{'1', ni, I}pk(ltkR)+      m2 = aenc{'2', ni, ~nr, $R}pkI+  in+    [ !Ltk($R, ltkR)+    , In( m1 )+    , !Pk(I, pkI)+    , Fr(~nr)+    ]+  --[ IN_R_1_ni( ni, m1 )+    , OUT_R_1( m2 )+    ]->+    [ Out( m2 )+    , St_R_1($R, I, ni, ~nr)+    ]++rule I_2:+  let m2 = aenc{'2', ni, nr, R}pk(ltkI)+      m3 = aenc{'3', nr}pkR+  in+    [ St_I_1(I, R, ni)+    , !Ltk(I, ltkI)+    , In( m2 )+    , !Pk(R, pkR)+    ]+  --[ IN_I_2_nr( nr, m2)+    ]->+    [ Out( m3 )+    , Secret(I,R,nr)+    , Secret(I,R,ni)+    ]++rule R_2:+    [ St_R_1(R, I, ni, nr)+    , !Ltk(R, ltkR)+    , In( aenc{'3', nr}pk(ltkR) )+    ]+  --[]->+    [ Secret(R,I,nr)+    , Secret(R,I,ni)+    ]++/* TODO: Also model session-key reveals and adapt security properties. */+rule Secrecy_claim:+  [ Secret(A, B, m) ] --[ Secret(A, B, m) ]-> []++++/* Note that we are using an untyped protocol model.+The contents of the 'ni' variable in rule R_1 may therefore in general be any+message. This leads to unsolved chain constraints when checking what message+can be extracted from the message sent by rule R_1. In order to get rid of+these constraints, we require the following typing invariant that relates the+point of instantiation to the point of sending by either the adversary or the+initiator.++In order to understand the use of this typing invariant you might try the+follwing experiment. Comment out this typing invariant and then check the+precomputed case distinctions in the GUI. Try to complete the proof of the+'nonce_secrecy' lemma.+*/+lemma types [typing]:+  " (All ni m1 #i.+       IN_R_1_ni( ni, m1) @ i+       ==>+       ( (Ex f #j. KU(f, ni) @ j & j < i)+       | (Ex #j. OUT_I_1( m1 ) @ j)+       )+    )+  & (All nr m2 #i.+       IN_I_2_nr( nr, m2) @ i+       ==>+       ( (Ex f #j. KU(f, nr) @ j & j < i)+       | (Ex #j. OUT_R_1( m2 ) @ j)+       )+    )+  "++// Nonce secrecy from the perspective of both the initiator and the responder.+lemma nonce_secrecy:+  " /* It cannot be that */+    not(+        Ex A B s #i.+          /* somebody claims to have setup a shared secret, */+          Secret(A, B, s) @ i+          /* but the adversary knows it */+        & (Ex #j. K(s) @ j)+          /* without having performed a long-term key reveal. */+        & not (Ex #r. RevLtk(A) @ r)+        & not (Ex #r. RevLtk(B) @ r)+       )"+++// Consistency check: ensure that secrets can be shared between honest agents.+lemma session_key_setup_possible:+  exists-trace+  " /* It is possible that */+    Ex A B s #i.+      /* somebody claims to have setup a shared secret, */+      Secret(A, B, s) @ i+      /* without the adversary having performed a long-term key reveal. */+    & not (Ex #r. RevLtk(A) @ r)+    & not (Ex #r. RevLtk(B) @ r)+  "++end
+ data/examples/classic/TLS_Handshake.spthy view
@@ -0,0 +1,187 @@+theory TLS_Handshake+begin++builtins: hashing, symmetric-encryption, asymmetric-encryption, signing++section{* TLS Handshake *}++/*+ * Protocol:	TLS Handshake+ * Modeler: 	Simon Meier, minor update by Cas Cremers+ * Date: 	January 2012+ * Source:	Modeled after Paulson`s TLS model in Isabelle/src/HOL/Auth/TLS.thy.+ *+ * Status: 	working (2.5 seconds on an i7 Quad-Core CPU with +RTS -N)+ */++text{*+  Modeled after Paulson`s TLS model in Isabelle/src/HOL/Auth/TLS.thy. Notable+  differences are:++    1. We use explicit global constants to differentiate between different+       encryptions instead of implicit typing.++    2. We model session keys directly as hashes of the relevant information.+       Due to our support for composed keys, we do not need any custom+       axiomatization as Paulson does.++*}++functions: PRF/1++// Public key infrastructure+rule Register_pk:+  [ Fr(~ltkA) ]+  -->+  [ !Ltk($A, ~ltkA), !Pk($A, pk(~ltkA)), Out(pk(~ltkA)) ]++rule Reveal_ltk:+  [ !Ltk(A, ltkA) ] --[ RevLtk(A)    ]-> [ Out(ltkA) ]+++/* We formalize the following signature based TLS handshake.++  protocol TLS {+    1. C -> S: C, nc, sid, pc+    2. C <- S: ns, sid, ps++    3. C -> S: { '31', pms                     }pk(S) ,+               sign{ '32', h('32', ns, S, pms) }pk(C) ,+               { '33', sid, PRF(pms, nc, ns),+                 nc, pc, C, ns, ps, S+               }+               h('clientKey', nc, ns, PRF(pms, nc, ns))++    4. C <- S: { '4', sid, PRF(pms, nc, ns),+                 nc, pc, C, ns, ps, S+               }+               h('serverKey', nc, ns, PRF(pms, nc, ns))+  }+*/++rule C_1:+    [ Fr(~nc)+    , Fr(~sid)+    ]+  --[]->+    [ Out(+        <$C, ~nc, ~sid, $pc>+      )+    , St_C_1($C, ~nc, ~sid, $pc)+    ]++rule S_1:+    [ In(+        <$C, nc, sid, pc>+      )+    , Fr(~ns)+    ]+  --[]->+    [ Out(+        <$S, ~ns, sid, $ps>+      )+    , St_S_1($S, $C, sid, nc, pc, ~ns, $ps)+    ]++rule C_2:+  let+      MS   = PRF(~pms, nc, ns)+      Ckey = h('clientKey', nc, ns, MS)+  in+    [ St_C_1(C, nc, sid, pc)+    , In(+        <S, ns, sid, ps>+      )+    , Fr(~pms)+    , !Pk(S, pkS)+    , !Ltk(C, ltkC)+    ]+  --[]->+    [ Out(+        < aenc{ '31', ~pms }pkS+        , sign{ '32', h('32', ns, S, ~pms) }ltkC+        , senc{ '33', sid, MS, nc, pc, C, ns, ps, S}Ckey+        >+      )+    , St_C_2(S, C, sid, nc, pc, ns, ps, ~pms)+    ]++rule S_2:+  let+      MS   = PRF(pms, nc, ns)+      Ckey = h('clientKey', nc, ns, MS)+      Skey = h('serverKey', nc, ns, MS)+  in+    [ St_S_1(S, C, sid, nc, pc, ns, ps)+    , In(+        < aenc{ '31', pms }pk(ltkS)+        , signature+        , senc{ '33', sid, MS, nc, pc, C, ns, ps, S}Ckey+        >+      )+    , !Pk(C, pkC)+    , !Ltk(S, ltkS)+    ]+    /* Explicit equality check, enforced as part of the property. */+  --[ Eq(verify(signature, <'32', h('32', ns, S, pms)>, pkC), true )+    , SessionKeys( S, C, Skey, Ckey )+    ]->+    [ Out(+        senc{ '4', sid, MS, nc, pc, C, ns, ps, S}Skey+      )+    ]++rule C_3:+  let+      MS   = PRF(pms, nc, ns)+      Ckey = h('clientKey', nc, ns, MS)+      Skey = h('serverKey', nc, ns, MS)+  in+    [ St_C_2(S, C, sid, nc, pc, ns, ps, pms)+    , In( senc{ '4', sid, MS, nc, pc, C, ns, ps, S}Skey )+    ]+  --[ SessionKeys( S, C, Skey, Ckey ) ]->+    []+++/* TODO: Also model session-key reveals and adapt security properties. */+++/* Session key secrecy from the perspective of both the server and the client+ * for both the key of the server and the key of the client. Note that this+ * lemma thus captures four security properties at once. */+lemma session_key_secrecy:+  " /* If all equality checks succeeded */+    (All x y #i. Eq(x,y) @ i ==> x = y)+  ==>+    /* then there is no attack */+    (not(+         /* It cannot be that */+         Ex S C keyS keyC #k.+           /* somebody claims to have setup session keys, */+           SessionKeys(S, C, keyS, keyC) @ k+           /* but the adversary knows one of them */+         & ( (Ex #i. K(keyS) @ i)+           | (Ex #i. K(keyC) @ i)+           )+           /* without having performed a long-term key reveal. */+         & not (Ex #r. RevLtk(S) @ r)+         & not (Ex #r. RevLtk(C) @ r)+    )   )"++/* Consistency check: ensure that session-keys can be setup between honest+ * agents. */+lemma session_key_setup_possible:+  exists-trace+  " /* There is a trace satisfying all equality checks */+     (All x y #i. Eq(x,y) @ i ==> x = y)+  &  /* Session keys have been setup */+     (Ex S C keyS keyC #k.  SessionKeys(S, C, keyS, keyC) @ k+      /* without having performed a long-term key reveal. */+      & not (Ex #r. RevLtk(S) @ r)+      & not (Ex #r. RevLtk(C) @ r)+      )+   "++end+
+ data/examples/loops/Minimal_Create_Use_Destroy.spthy view
@@ -0,0 +1,46 @@+theory Minimal_Create_Use_Destroy begin++++text{*+  Author: Simon Meier <simon.meier@inf.ethz.ch>+  Date:   2011 12 01+  Status: Working++  One model of the key mechnaism for certificate revocation.+  For every certificate, we create a single fact denoting that+  it has not yet been revoked. In every use of the certificate,+  we check that this fact still exists.++*}++rule Create:+    [ Fr(x) ]+  --[ Create(x) ]->+    [ Object(x) ]++rule Use:+    [ Object(x) ]+  --[ Use(x) ]->+    [ Object(x) ]++rule Destroy:+    [ Object(x) ]+  --[ Destroy(x) ]->+    []++lemma Use_charn [reuse, use_induction]:+  "All x #j. Use(x) @ j ==>+    (Ex #i. Create(x) @ i & i < j)+  "++lemma Destroy_charn [reuse, use_induction]:+  "All x #j. Destroy(x) @ j ==>+    ( (Ex #i. Create(x) @ i & i < j)+    & (All #i. Use(x) @ i  ==>  i < j)+    & (All #i. Destroy(x) @ i  ==>  #i = #j)+    )+  "+++end
+ data/examples/loops/Minimal_Crypto_API.spthy view
@@ -0,0 +1,69 @@+theory Minimal_Crypto_API
+begin
+
+builtins: symmetric-encryption
+
+/*
+ * Protocol:	Minimal example of handle-based crypto
+ * Modeler: 	Simon Meier
+ * Date: 	April 2012
+ *
+ * Status: 	working
+
+ This example demonstrates the verification problem that we face when
+ reasoning about handle-based cryptography. The protocol is simple. It models
+ a crypto coprocessor that can generate new keys, use them to encrypt data,
+ and wrap keys with other stored keys.
+
+ */
+
+
+/* Generate a fresh handle and a fresh key, store their association, and
+ * output the handle */
+rule NewKey:
+  [ Fr(~h), Fr(~k) ]
+  --[ NewKey(~h,~k) ]->
+  [ !Store(~h,~k) , Out(~h) ]
+
+/* Encrypt a message using a key referenced by a handle */
+rule EncryptMsg:
+  [ !Store(h,k), In(<h, m>)]
+  -->
+  [ Out( senc{m}k ) ]
+
+/* Wrap a key reference by a handle using another key referenced by a second
+ * handle */
+rule WrapKey:
+  [ !Store(h1,k1), !Store(h2,k2), In(<h1,h2>)]
+  -->
+  [ Out( senc{k1}k2 ) ]
+
+
+/* The 'reuse' attribute marks this property such that it should be used in
+ * proof of later theorems. This is what we'd like to do with such a property
+ * which proves that no created key can be deduced by the adversary. The
+ * 'invariant' attribute denotes that this property is an inductive invariant
+ * of normal dependency graphs. This instructs Tamarin to use induction as the
+ * first proof step.
+ *
+ * Note that construction of using 'Ded'-facts to log the conclusions of
+ * construction rules is work in progress. Tamarin is missing some constraint
+ * reduction rules to infer the presence of 'Ded'-facts in all cases.
+ * Moreover, it might also miss some rules to deal with the 'Last(i)' atoms,
+ * which states that 'i' is the last index in the trace that is annotated with
+ * an action.
+ *
+ * Tamarin can prove this property automatically.
+ */
+lemma NewKey_invariant [reuse, use_induction]:
+  "not(Ex #i #j h k f. NewKey(h, k) @ i & KU(f,k) @ j) "
+
+/* This property talks only about standard traces that do not refer to the
+ * actions of construction rules. It can be proven thanks to the
+ * NewKey_invariant proven before. Try an interactive proof after removing the
+ * 'reuse' flag above to see what goes wrong without induction and the 'Ded'
+ * facts. */
+lemma NewKey_secrecy:
+  "not(Ex #i #j h k. NewKey(h, k) @ i & K(k) @ j) "
+
+end
+ data/examples/loops/Minimal_KeyRenegotiation.spthy view
@@ -0,0 +1,42 @@+theory KeyRenegotiation_Minimal begin++/*+   Protocol:    A minimal version of a key renegotiation protocol.+   Modeler:     Simon Meier+   Date:        May 2012++   Status:      working++   Minimal example of the verification of a protocol with repeated key+   re-negotiation.++*/++builtins: symmetric-encryption++rule Setup:+    [ Fr(~k) ]+  -->+    [ Sender(~k), Receiver(~k) ]++rule Send:+    [ Sender(k0), Fr(~k) ]+  --[ Secret(~k) ]->+    [ Sender(~k), Out( senc{~k}k0 ) ]+++rule Receive:+    [ Receiver(k0), In(senc{k}k0) ]+  --[ Secret(k) ]->+    [ Receiver(k) ]++lemma Secret_reachable [use_induction]:+  exists-trace+  "Ex k #i. Secret(k) @ i"++// TODO: Investigate the form of the property and its proof when key+// compromise is allowed.+lemma secrecy [use_induction]:+  "All k f #i #j. Secret(k) @ i & KU(f,k) @ j ==> F"++end
+ data/examples/loops/TESLA_Scheme1.spthy view
@@ -0,0 +1,107 @@+theory TESLA_Scheme1 begin++/*+  Protocol:    The TESLA protocol, scheme 1+  Modeler:     Simon Meier+  Date:        May 2012++  Status:      WIP+++    Msg 0a. R -> S: nR+    Msg 0b. S -> R: {f (k1 ), nR }SK (S )+    Msg 1.  S -> R: D1 , MAC (k1 , D1 ) where D1 = m1 , f (k2 )+    Msg 2.  S -> R: D2 , MAC (k2 , D2 ) where D2 = m2 , f (k3 ), k1 .++  For n > 1, the n-th message is:2+    Msg n. S -> R : Dn , MAC (kn , Dn ) where Dn = mn , f (kn+1 ), kn-1 .++*/++functions: MAC/2, f/1++rule Setup:+    [ Fr(~k1) ]+  -->+    [ Sender1(~k1)+    , Receiver1(f(~k1))+    ]++rule Send1:+  let data1 = <'1', ~m1, f(~k2)>+  in+    [ Sender1(~k1)+    , Fr(~m1)+    , Fr(~k2)+    ]+  --[ Sent(data1)+    ]->+    [ Sender(~k1, ~k2)+    , Out( < data1, MAC{data1}~k1 > )+    ]++rule Recv1:+  let data1 = <'1', m1, commit_k2>+  in+    [ Receiver1(commit_k1)+    , In( <data1, mac1> )+    ]+  --[ AssumeCommitNotExpired(commit_k1)+    ]->+    [ Receiver(data1, mac1, commit_k1, commit_k2) ]++rule SendN:+  let data = <'N', ~m, f(~kNew), ~kOld>+  in+    [ Sender(~kOld, ~k)+    , Fr(~m)+    , Fr(~kNew)+    ]+  --[ Sent(data)+    , CommitExpired(f(~kOld))+    ]->+    [ Sender(~k, ~kNew)+    , Out( <data, MAC{data}~k> )+    ]++rule Recv:+  let data = <'N', m, commit_kNew, kOld>+  in+    [ In(< data, mac >)+    , Receiver(dataOld, MAC{dataOld}kOld, f(kOld), commit_k)+    ]+  --[ ClaimSent(dataOld)+    , AssumeCommitNotExpired(commit_k)+    ]->+    [ Receiver(data, mac, commit_k, commit_kNew) ]++lemma claim_reachable [use_induction]:+  exists-trace+  "(All commit #i #j .+        AssumeCommitNotExpired(commit) @ i+      & CommitExpired(commit) @ j+        ==> i < j+   )+   ==>+   (Ex m #i. ClaimSent(m) @ i)+  "++lemma authentic2 [use_induction]:+  "(All commit #i #j .+        AssumeCommitNotExpired(commit) @ i+      & CommitExpired(commit) @ j+        ==> i < j+   )+   ==>+   (All m #i. ClaimSent(m) @ i ==> (Ex #j. Sent(m) @ j & j < i) )+  "++++++++++end
+ data/examples/related_work/AIF_Moedersheim_CCS10/Keyserver.spthy view
@@ -0,0 +1,121 @@+theory Keyserver begin++/*+ * Protocol:	The keyserver example from [1]+ * Modeler: 	Simon Meier+ * Date: 	June 2012+ *+ * Status: 	working++ [1] Sebastian Moedersheim: Abstraction by set-membership: verifying security+ protocols and web services with databases. ACM Conference on Computer and+ Communications Security 2010: 351-360+ */++/* Original input file from [1]++Problem: zebsKeyserver;++Types:+Agent  : {a,b,c,i,s};+U      : {a,b,c};+S      : {s};+H      : {a,b};+D      : {c,i};+DU     : {c};+Sts    : {valid,revoked};+PK,NPK : value;+M1,M2  : untyped;++Sets:+ring(U), db(S,U,Sts);++Functions:+public sign/2, pair/2;+private inv/1;++Facts:+iknows/1, attack/0;++Rules:++\Agent. => iknows(Agent);+iknows(sign(M1,M2)) => iknows(M2);+iknows(M1).iknows(M2) => iknows(sign(M1,M2));+iknows(pair(M1,M2)) => iknows(M1).iknows(M2);+iknows(M1).iknows(M2) => iknows(pair(M1,M2));+*/++builtins: signing++// The non-deterministic choice between the rules SetupHonestKey and+// SetupDishonestKey determines whether an agent is honest or not.++// \H,S. =[PK]=>iknows(PK).PK in ring(H).PK in db(S,H,valid);+rule SetupHonestKey:+    [ Fr(~sk) ]+  --[ HonestKey(~sk) ]->+    [ Out(pk(~sk)), ClientKey($A, ~sk), ServerDB($A, ~sk) ]++// \S,DU. =[PK]=>iknows(PK).iknows(inv(PK)).PK in db(S,DU,valid);+rule SetupDishonestKey:+    [ In(sk) ]+  -->+    [ ServerDB($A, sk) ]++// \H.+// iknows(PK).PK in ring(H)+// =[NPK]=>NPK in ring(H).iknows(sign(inv(PK),pair(H,NPK)));+rule RequestRenewKey:+    [ ClientKey($A, sk), Fr(~skNew) ]+  --[ HonestKey(~skNew) ]->+    [ Out( sign{'renew', $A, pk(~skNew)}sk )+    , ClientKey($A, ~skNew)+    ]++// \S,U.+// iknows(sign(inv(PK),pair(U,NPK))).PK in db(S,U,valid).+// forall U,Sts. NPK notin db(S,U,Sts)+// =>PK in db(S,U,revoked).NPK in db(S,U,valid).iknows(inv(PK));+rule RenewKey:+    [ In( sign{'renew', A, pk(skNew)}sk )+    , ServerDB(A, sk)+    ]+  --[ Revoked(sk) ]->+    [ ServerDB(A, skNew)+    , Out( sk )+    ]++// Typing lemma: it can be proven, but not with the current heuristic. It+// focuses too much on the first-order part and neglects solving the+// signature. Moreover, it should use an age-based strategy for the goals to+// ensure that it always makes at least some progress.+lemma types [typing]:+  "All sk #i. Revoked(sk) @ i ==>+     ( (Ex f #j. KU(f,sk) @ j & j < i)+     | (Ex #j. HonestKey(sk) @ j & j < i)+     )+  "+/*+The following property proven in Moedersheim's paper is rather easy to+prove, as it depends only on the fact that secret keys are not leaked by+any other means than the "RenewKey" rule. The "RenewKey" rule always log's+that the key is "Revoked", which directly implies the lemma below.++TODO: Prove property that depends on ordering of revocation. For example,+DH-key exchange always succeeds for a protocol with an online key-server. This+crucially depends on the client not sending a renewal message while he's+waiting for the key confirmation.+*/+++// \S,H.+// iknows(inv(PK)).PK in db(S,H,valid)+// =>attack;+lemma In_Honest_Key_imp_Revoked:+  "All sk #i #d. HonestKey(sk) @ i & K(sk) @ d ==>+      (Ex #r. Revoked(sk) @ r)+  "+++end
+ data/examples/related_work/StatVerif_ARR_CSF11/StatVerif_Example1.spthy view
@@ -0,0 +1,149 @@+theory StatVerif_Example1 begin++/*+   Protocol:    Simple security device (Example 1 from [1])+   Modeler:     Simon Meier+   Date:        May 2012++   Status:      working++   This is the simple security device example presented in Section V.A of the+   following paper.++   [1] M. Arapinis, E. Ritter and M. Ryan. StatVerif: Verification of Stateful+   Processes. In CSF'11. IEEE Computer Society Press, pages 33-47 , 2011.++   It models a hardware device that stores both a private key and a+   configuration register that can be set to 'left' for decrypting the first+   component of tuples encrypted using the device's public key and 'right' for+   decrypting the second component of tuples encrypted using the device's+   public key. Alice uses such a device to encrypt tuples such that Bob+   can access either all their first components or all their second+   components, but never both.++   Note that in contrast to [1], we allow the creation of an unbounded number+   of devices. We also verify both the accessability of left and right+   components, as well as their exclusivity. The source code of the model+   from [1] is attached at the end of this file.++*/++builtins: asymmetric-encryption+++// Create a new device. It stores the private key and publishes the+// corresponding public key.+rule NewDevice:+    [ Fr(~sk)  // We let the key identify the device.+    ]+  -->+    [  UnconfiguredDevice(~sk)+    , !DevicePublicKey(pk(~sk))+    ,  Out(pk(~sk))+    ]++// Alice can use any public key associated to such a hardware security device+// for publishing messages with exclusive access.+rule Alice:+    [  Fr(~x)+    ,  Fr(~y)+    , !DevicePublicKey(key)+    ]+  --[ Exclusive(~x,~y) ]->+    [ Out( aenc{~x,~y}key )+    ]++// Unconfigured devices can be configured exactly once.+rule ConfigureDevice:+    [ UnconfiguredDevice(sk), In(config) ]+    -->+    [ !ConfiguredDevice(sk, config) ]++// Devices configured to 'left' can be used to decrypt the first component of+// messages encrypted using the device's public key.+rule UseLeftDevice:+    [ !ConfiguredDevice(sk, 'left'), In(aenc{x,y}pk(sk)) ]+  --[ Access(x) ]->+    [ Out(x) ]++// Devices configured to 'right' can be used to decrypt the second component of+// messages encrypted using the device's public key.+rule UseRightDevice:+    [ !ConfiguredDevice(sk, 'right'), In(aenc{x,y}pk(sk)) ]+  --[ Access(y) ]->+    [ Out(y) ]+++// As we use a backwards search, we must specify the possible structure of+// messages sent in 'UseLeftDevice' and 'UseRightDevice' precise enough such+// that we can solve all chain constraints starting from the sent message. We+// therefore log the message being accessed and relate it to its possible+// origins: known to the intruder in an earlier step or part of an exclusive+// message generated by 'Alice'. Typing lemmas are proven by induction and+// incorporated in the case distinction precomputation.+lemma types [typing]:+  "All m #i. Access(m) @ i ==>+      (Ex f #j. KU(f,m) @ j & j < i)  // Make use of the KU-facts logged+                                      // by the construction rules.+    | (Ex x #j. Exclusive(x,m) @ j)+    | (Ex y #j. Exclusive(m,y) @ j)+  "++// Check that there is some trace where the intruder knows the left message of+// an exclusive message-tuple. In contrast to the typing lemma, we use the+// standard 'K'-fact, which is logged by the built-in 'ISend' rule.+lemma reachability_left:+  exists-trace+  "Ex x y #i #j. Exclusive(x,y) @i & K(x) @ j"++lemma reachability_right:+  exists-trace+  "Ex x y #i #k. Exclusive(x,y) @i & K(y) @ k"++// Check that exclusivity is maintained+lemma secrecy:+  "not(Ex x y #i #k1 #k2.+         Exclusive(x,y) @i & K(x) @ k1 & K(y) @ k2+      )+  "++end++/* StatVerif source code of the original model from [1].++fun pair/2.+fun aenc/3.+fun pk/1.+free left.+free right.+free init.+free c.++reduc+    projl(pair(xleft, xright)) = xleft;+    projr(pair(xleft, xright)) = xright;+    adec(u, aenc(pk(u), v, w)) = w.++query+    att:vs,pair(sl,sr).++let device =+    out(c, pk(k)) |+    ( ! lock(s); in(c, x); read s as y;+        if y = init then+            (if x = left then s := x; unlock(s)+            else if x = right then s := x; unlock(s))  ) |+    ( ! lock(s); in(c, x); read s as y; let z = adec(k, x) in+        let zl = projl(z) in+        let zr = projr(z) in+        ((if y = left then out(c, zl); unlock(s)) |+         (if y = right then out(c, zr); unlock(s)))).++let user =+    new sl; new sr; new r;+        out(c, aenc(pk(k), r, pair(sl,sr))).++process+    new k; new s; [s |-> init] | device | ! user++*/
+ data/examples/related_work/TPM_DKRS_CSF11/Envelope.spthy view
@@ -0,0 +1,179 @@+theory TPM_Envelope begin++text{* Envelope protocol example from:++[1] Stephanie Delaune, Steve Kremer, Mark D. Ryan, Graham Steel, "Formal+Analysis of Protocols Based on TPM State Registers," csf, pp.66-80, 2011 IEEE+24th Computer Security Foundations Symposium, 2011.++Modeler: Simon Meier+Date:    June 2012+Status:  No automatic proof (interactive proof possible)++Note that this model incorporates an arbitrary number of reboots, which is an+open problem in [1]. The verification relies on the construction that we track+all writes to the PCR-fact using the additional PCR_Write-fact. This allows us+then to descend in the hash chain by solving PCR_Write-premises.++*}++builtins: signing, asymmetric-encryption, hashing++// TPM platform configuration register (PCR) model+// Here, we model only one PCR. Modelling multiple PCR's can be done by+// parametrizing their facts on an additional term used to identify them.+rule PCR_Init:+    [ Fr(~aik)             // Authentication identity key+    ]+  --[+      PCR_Init()           // Used in property to ensure at most one initialization+    , PCR_Write('pcr0')+    ]->+    [ PCR('pcr0')          // the initial PCR value is 'pcr0'+    , PCR_Write('pcr0')    // We also track the writes.+    , !AIK(~aik)           // the auth. id. key is persistent+    , Out(pk(~aik))        // publish the public key of the auth. id. key+    ]++// reset the PCR to 'pcr0'+rule PCR_Reboot:+    [ PCR(x)+    , PCR_Write(x)+    ]+  --[ PCR_Write('pcr0')+    ]->+    [ PCR_Write('pcr0')+    , PCR('pcr0')+    ]++// Extend the hash-chain in the PCR+rule PCR_Extend:+    [ PCR_Write(x)       // Get write access+    , PCR(x)             //+    , In(y)              // The adversary can present any value.+    ]+  --[ PCR_Write(h(x,y))+    ]->+    [ PCR(h(x,y))+    , PCR_Write(h(x,y))+    ]++// Certify a key together with the value it is locked to.+rule PCR_CertKey:+    [ !AIK(aik)+    , !KeyTable(lock, sk)+    ]+  --[ ]->+    [ Out(sign{'certkey', lock, pk(sk)}aik)+    ]++// Quote the current value of the PCR+rule PCR_Quote:+    [ PCR(x)+    , !AIK(aik)+    ]+  --[ PCR_Read(x)+    ]->+    [ Out(sign{'certpcr', x}aik)+    , PCR(x)+    ]++// Decrypt a message encrypted with a key locked to the CURRENT value of the+// PCR.+rule PCR_Unbind:+    [ PCR(x)+    , !KeyTable(x, sk)+    , In( aenc{m}pk(sk) )+    ]+  --[ PCR_Unbind(x,sk,m)+    , PCR_Read(x)+    ]->+    [ PCR(x)+    , Out(m) ]++// Alice++// Alice starts by communicating with Bob's PCR to setup a unique root ~n in+// the hash-chain for the following envelope protocol.+rule Alice1:+    [ Fr(~n)+    , PCR(x)+    , PCR_Write(x)+    ]+  --[ PCR_Write(h(x,~n))+    ]->+    [ PCR(h(x,~n))+    , PCR_Write(h(x,~n))+    , Alice1(~n)+    ]++// Bob sends Alice a certified key locked to the value+//   h(h('pcr0',n),'obtain')+// to obtain a secret in an envelope. Note that we only allow for one session+// per reboot as [1].+rule Alice2:+    [ Alice1(n)+    , Fr(~s)+    , !AIK(aik)+    , In(sign{'certkey', h(h('pcr0',n),'obtain'), pk}aik)+    ]+  --[ Secret(~s)+    ]->+    [ Out(aenc{~s}pk)+    , Alice2(n,~s)+    ]++// Bob can use the PCR to prove to Alice that he didn't access the secret.+rule Alice3:+    [ Alice2(n,s)+    , !AIK(aik)+    , In(sign{'certpcr', h(h('pcr0',n),'deny')}aik)+    ]+  --[ Denied(s) ]->+    []++// We use the adversary to simulate Bob. He uses ordinary message deduction+// and it can create keys locked to specific values of the PCR.+rule CreateLockedKey:+    [ PCR(x)+    , Fr(~sk)+    , In(lock) // multiple keys can be locked to the same PCR value.+    ]+  --[ PCR_Read(x)+    ]->+    [ PCR(x)+    , !KeyTable(h(x,lock), ~sk)+    , Out(pk(~sk))+    ]++// Automatically proven+lemma types [typing]:+    // Values created by the PCR_Unbind rule+  " (All m d1 d2 #i. PCR_Unbind(d1, d2, m) @ i ==>+        (Ex f #j. KU(f,m) @ j & j < i)+      | (Ex #j. Secret(m) @ j)+    )+  "++// Automatically proven+lemma PCR_Write_charn [reuse, use_induction]:+    // Values read from the PCR have been written to it beforehand.+  " (All x #i. PCR_Read(x) @ i ==>+      (Ex #j. PCR_Write(x) @ j)+    )+  "++// Assuming that there is at most one instance of the PCR,+// the adversary (playing Bob) must not know a secret that Alice created and+// thinks that access to it was denied.+//+// Currently, we have to construct its proof manually. The key argument relies+// on following the PCR_Write-premises once their presence has been+// established via the PCR_Write_charn lemma.+lemma reachable_Denied:+  "(All #i #j. PCR_Init() @ i & PCR_Init() @ j ==> #i = #j)+   ==>+   not(Ex s #i #j #k. Secret(s) @ i & Denied(s) @ j & K(s) @ k)"+++end
+ data/examples/related_work/TPM_DKRS_CSF11/RunningExample.spthy view
@@ -0,0 +1,123 @@+theory CSF11_RunningExample begin++text{* Running example from:++Stephanie Delaune, Steve Kremer, Mark D. Ryan, Graham Steel, "Formal Analysis+of Protocols Based on TPM State Registers," csf, pp.66-80, 2011 IEEE 24th+Computer Security Foundations Symposium, 2011.++Modeler: Simon Meier+Date:    June 2012+Status:  Working++*}++builtins: hashing, asymmetric-encryption, signing++// TPM PCR model+rule PCR_Init:+    [ Fr(~aik)          // Authentication identity key+    ]+  --[ PCR_Init('pcr0',~aik)+    , UniqueInit()      // For removing traces that have multiple initializations+    ]->+    [ PCR('pcr0')       // the initial PCR value is 'pcr0'+    , !AIK(~aik)        // the auth. id. key is persistent+    , Out(pk(~aik))     // publish the public key of the auth. id. key+    ]+++// Disabled, as the protocol is not secure under reboots.+// TODO: Check that we can find the attack.+//+// Note that we miss the attack, as we do not consider collapsing different+// PCR_Unbind nodes. In order to find this attack, we would require to+// introduce strongly different node variables.+//+// rule PCR_Reboot:+//     [ PCR(x) ] --> [ PCR('pcr0') ]  // reset the PCR to 'pcr0'++rule PCR_Extend:+    [ PCR(x)+    , In(y)+    ]+  --[ PCR_Extend(x,y,h(x,y))+    ]->+    [ PCR(h(x,y))+    ]++rule PCR_CertKey:+    [ !AIK(aik)+    , !KeyTable(x, sk)+    ]+  --[ PCR_CertKey_Inst(x)+    ]->+    [ Out(sign{'certkey', x, pk(sk)}aik) ]++rule PCR_Unbind:+    [ PCR(x)+    , !KeyTable(x, sk)+    , In( aenc{m}pk(sk) )+    ]+  --[ PCR_Unbind(x,sk,m)+    ]->+    [ PCR(x)+    , Out(m) ]++// Alice+rule Alice_Init:+    [ Fr(~s0)+    , Fr(~s1)+    , !AIK(aik)+    , In(sign{'certkey', x0, pk0}aik)+    , In(sign{'certkey', x1, pk1}aik)+    ]+  --[ Ineq(x0, x1)+    , Secrets(~s0,~s1)+    ]->+    [ Out(aenc{~s0}pk0)+    , Out(aenc{~s1}pk1)+    ]++// Keytable+rule MkKey:+    // Fr(<'MkKey',$a>)  // register at most one key per public constant+    [ Fr(~ska) ]+    -->+    [ !KeyTable(h('pcr0',$a), ~ska) ]++lemma types [typing]:+  " (All m d1 d2 #i. PCR_Unbind(d1, d2, m) @ i ==>+        (Ex f #j. KU(f,m) @ j & j < i)+      | (Ex s #j. Secrets(m, s) @ j)+      | (Ex s #j. Secrets(s, m) @ j)+    )+  "++lemma Unbind_PCR_Value [reuse, use_induction]:+    "All x sk m #i.+        PCR_Unbind(x, sk, m) @ i+        ==>+        ( (Ex aik #j.     PCR_Init(x, aik) @ j  )+        | (Ex y xPrev #j. PCR_Extend(xPrev,y,x) @ j)+        | (Ex #i #j. UniqueInit() @ j & UniqueInit() @ i & not (#i = #j))+        )+    "++lemma secrecy:+  " ( (All #i #j. UniqueInit() @ j & UniqueInit() @ i ==> #i = #j)+    & (All t #e. Ineq(t,t) @ e ==> F)+    ) ==>+    not( (Ex s0 s1 #i #d0 #d1.+             Secrets(s0, s1) @ i+           & K(s0) @ d0+           & K(s1) @ d1+       ) )"++++++++end
− data/examples/stable/InvariantsExample.spthy 
@@ -1,69 +0,0 @@-theory InvariantsExample
-begin
-
-builtins: symmetric-encryption
-
-/*
- * Protocol:	Minimal example of handle-based crypto
- * Modeler: 	Simon Meier
- * Date: 	April 2012
- *
- * Status: 	working
-
- This example demonstrates the verification problem that we face when
- reasoning about handle-based cryptography. The protocol is simple. It models
- a crypto coprocessor that can generate new keys, use them to encrypt data,
- and wrap keys with other stored keys.
-
- */
-
-
-/* Generate a fresh handle and a fresh key, store their association, and
- * output the handle */
-rule NewKey: 
-  [ Fr(~h), Fr(~k) ] 
-  --[ NewKey(~h,~k) ]-> 
-  [ !Store(~h,~k) , Out(~h) ]
-
-/* Encrypt a message using a key referenced by a handle */
-rule EncryptMsg:
-  [ !Store(h,k), In(<h, m>)] 
-  -->
-  [ Out( senc{m}k ) ]
-
-/* Wrap a key reference by a handle using another key referenced by a second
- * handle */
-rule WrapKey:
-  [ !Store(h1,k1), !Store(h2,k2), In(<h1,h2>)] 
-  -->
-  [ Out( senc{k1}k2 ) ]
-  
-
-/* The 'reuse' attribute marks this property such that it should be used in
- * proof of later theorems. This is what we'd like to do with such a property
- * which proves that no created key can be deduced by the adversary. The
- * 'invariant' attribute denotes that this property is an inductive invariant
- * of normal dependency graphs. This instructs Tamarin to use induction as the
- * first proof step.
- * 
- * Note that construction of using 'Ded'-facts to log the conclusions of
- * construction rules is work in progress. Tamarin is missing some constraint
- * reduction rules to infer the presence of 'Ded'-facts in all cases.
- * Moreover, it might also miss some rules to deal with the 'Last(i)' atoms,
- * which states that 'i' is the last index in the trace that is annotated with
- * an action.
- *
- * Tamarin can prove this property automatically.
- */
-lemma NewKey_invariant [reuse, invariant]:
-  "not(Ex #i #j h k. NewKey(h, k) @ i & Ded(k) @ j) "
-
-/* This property talks only about standard traces that do not refer to the
- * actions of construction rules. It can be proven thanks to the
- * NewKey_invariant proven before. Try an interactive proof after removing the
- * 'reuse' flag above to see what goes wrong without induction and the 'Ded'
- * facts. */
-lemma NewKey_secrecy:
-  "not(Ex #i #j h k. NewKey(h, k) @ i & K(k) @ j) "
-
-end
− data/examples/stable/TLS.spthy 
@@ -1,188 +0,0 @@-theory TLS -begin--builtins: hashing, symmetric-encryption, asymmetric-encryption, signing--section{* TLS Handshake *}--/*- * Protocol:	TLS Handshake- * Modeler: 	Simon Meier, minor update by Cas Cremers- * Date: 	January 2012- * Source:	Modeled after Paulson`s TLS model in Isabelle/src/HOL/Auth/TLS.thy.- *- * Status: 	working (2.5 seconds on an i7 Quad-Core CPU with +RTS -N)- */--text{*-  Modeled after Paulson`s TLS model in Isabelle/src/HOL/Auth/TLS.thy. Notable-  differences are:--    1. We use explicit global constants to differentiate between different-       encryptions instead of implicit typing.--    2. We model session keys directly as hashes of the relevant information.-       Due to our support for composed keys, we do not need any custom-       axiomatization as Paulson does.--*}--functions: PRF/1--// Public key infrastructure-rule Register_pk:-  [ Fr(~ltkA) ] -  --> -  [ !Ltk($A, ~ltkA), !Pk($A, pk(~ltkA)), Out(pk(~ltkA)) ]--rule Reveal_ltk:-  [ !Ltk(A, ltkA) ] --[ RevLtk(A)    ]-> [ Out(ltkA) ]---/* We formalize the following signature based TLS handshake.--  protocol TLS {-    1. C -> S: C, nc, sid, pc-    2. C <- S: ns, sid, ps--    3. C -> S: { '31', pms                     }pk(S) ,-               sign{ '32', h('32', ns, S, pms) }pk(C) ,-               { '33', sid, PRF(pms, nc, ns),-                 nc, pc, C, ns, ps, S-               } -               h('clientKey', nc, ns, PRF(pms, nc, ns))--    4. C <- S: { '4', sid, PRF(pms, nc, ns),-                 nc, pc, C, ns, ps, S-               } -               h('serverKey', nc, ns, PRF(pms, nc, ns))-  }-*/--rule C_1:-    [ Fr(~nc)-    , Fr(~sid)-    ]-  --[]->-    [ Out(-        <$C, ~nc, ~sid, $pc>-      )-    , St_C_1($C, ~nc, ~sid, $pc)-    ]--rule S_1:-    [ In( -        <$C, nc, sid, pc>-      )-    , Fr(~ns)-    ]-  --[]->-    [ Out(-        <$S, ~ns, sid, $ps>-      )-    , St_S_1($S, $C, sid, nc, pc, ~ns, $ps)-    ]--rule C_2:-  let -      MS   = PRF(~pms, nc, ns)-      Ckey = h('clientKey', nc, ns, MS)-  in -    [ St_C_1(C, nc, sid, pc)-    , In(-        <S, ns, sid, ps>-      )-    , Fr(~pms)-    , !Pk(S, pkS)-    , !Ltk(C, ltkC)-    ]-  --[]->-    [ Out(-        < aenc{ '31', ~pms }pkS-        , sign{ '32', h('32', ns, S, ~pms) }ltkC-        , senc{ '33', sid, MS, nc, pc, C, ns, ps, S}Ckey-        >-      )-    , St_C_2(S, C, sid, nc, pc, ns, ps, ~pms)-    ]--rule S_2:-  let -      MS   = PRF(pms, nc, ns)-      Ckey = h('clientKey', nc, ns, MS)-      Skey = h('serverKey', nc, ns, MS)-  in -    [ St_S_1(S, C, sid, nc, pc, ns, ps)-    , In(-        < aenc{ '31', pms }pk(ltkS)-        , signature-        , senc{ '33', sid, MS, nc, pc, C, ns, ps, S}Ckey-        >-      )-    , !Pk(C, pkC)-    , !Ltk(S, ltkS)-    ]-    /* Explicit equality check, enforced as part of the property. */-  --[ Eq(verify(signature, <'32', h('32', ns, S, pms)>, pkC), true )-    , SessionKeys( S, C, Skey, Ckey )-    ]->-    [ Out(-        senc{ '4', sid, MS, nc, pc, C, ns, ps, S}Skey-      )-    ]--rule C_3:-  let -      MS   = PRF(pms, nc, ns)-      Ckey = h('clientKey', nc, ns, MS)-      Skey = h('serverKey', nc, ns, MS)-  in -    [ St_C_2(S, C, sid, nc, pc, ns, ps, pms)-    , In( senc{ '4', sid, MS, nc, pc, C, ns, ps, S}Skey )-    ]-  --[ SessionKeys( S, C, Skey, Ckey ) ]->-    []---/* TODO: Also model session-key reveals and adapt security properties. */---/* Session key secrecy from the perspecitive of both the server and the client- * for both the key of the server and the key of the client. Note that this- * lemma thus captures four security properties at once. */-lemma session_key_secrecy:-  " /* If all equality checks succeeded */-    (All x y #i. Eq(x,y) @ i ==> x = y)-  ==>-    /* then there is no attack */ -    (not( -         /* It cannot be that */-         Ex S C keyS keyC #k.-           /* somebody claims to have setup session keys, */-           SessionKeys(S, C, keyS, keyC) @ k -           /* but the adversary knows one of them */-         & ( (Ex #i. K(keyS) @ i) -           | (Ex #i. K(keyC) @ i)-           )-           /* without having performed a long-term key reveal. */-         & not (Ex #r. RevLtk(S) @ r)-         & not (Ex #r. RevLtk(C) @ r)-    )   )"--/* Consistency check: this lemma must NOT have a proof,- * as otherwise no session-keys could be setup between honest agents. */-lemma session_key_setup_possible:-  exists-trace-  " /* There is a trace satisfying all equality checks */-     (All x y #i. Eq(x,y) @ i ==> x = y)-  &  /* Session keys have been setup */-     (Ex S C keyS keyC #k.  SessionKeys(S, C, keyS, keyC) @ k -      /* without having performed a long-term key reveal. */-      & not (Ex #r. RevLtk(S) @ r)-      & not (Ex #r. RevLtk(C) @ r)-      )-   "---end-
− data/examples/stable/Tutorial.spthy 
@@ -1,403 +0,0 @@-/*-Tutorial for the Tamarin prover for security protocol analysis-==============================================================--Authors: 	Simon Meier, Benedikt Schmidt-Date: 	        April 2012---Introduction---------------This user guide assumes that you have a copy of our CSF'12 paper on-"Automated Analysis of Diffie-Hellman Protocols and Advanced Security-Properties", whose extended version is available from-http://www.infsec.ethz.ch/research/software#TAMARIN.--The input files for the Tamarin prover have the extension .spthy, which is-short for 'security protocol theory'. A security protocol theory specifies--  1. the signature and equational theory to use for the message algebra,-  2. the set of set of multiset rewriting rules modeling the protocol and-     the adversary capabilities, and-  3. the guarded trace properties whose validity we wish to check for this-     set of multiset rewriting rules.--We explain each of these parts where they occur in the following security-protocol theory. Before we start, a few notes on the syntax.-As you probably noticed, comments are C-style. All identifiers are-case-sensitive. The parser is layout-insensitive, i.e., your are free to use-whitespace as it suits you. We provide a complete specification of the input-syntax in the reference MANUAL.---Modeling a security protocol-------------------------------Every security protocol theory starts with a header of the following form.-*/--theory Tutorial-begin--/*-Obviously, you can replace 'Tutorial' with any name you like to give your-theory. After 'begin', you can declare function symbols, equations that they-must satisfy, multiset rewriting rules, and lemmas specifying security-properties. Moreover, you can also insert formal comments, to structure your-theory. We give examples of each of these elements while modeling the-a simple protocol. --In this protocol, a client C generates a fresh symmetric key 'k', encrypts it-with the public key of a server 'S' and sends it to 'S'. The server confirms-the receipt of the key by sending back its hash to the client. In-Alice-and-Bob notation the protocol would read as follows.--  C -> S: aenc{k}pk(S)-  C <- S: h(k)--This protocol is artificial and it satisfies only very weak security-guarantees. We can prove that from the perspective of the client, the freshly-generated key is secret provided that the server is uncompromised.--We model this protocol in three steps. First, we declare the function symbols-and the equations defining them. Then, we introduce multiset rewriting rules-modeling a public key infrastructure (PKI) and the protocol. Finally, we state-the expected security properties.---Function Signature and Equational Theory-------------------------------------------We model hashing using the unary function 'h'.-We model asymmetric encryption by declaring -  a binary function 'aenc' denoting the encryption algorithm,-  a binary function 'adec' denoting the decryption algorithm, and-  a unary function 'pk' denoting the algorithm computing a public-  key from a private key.-*/--functions: h/1, aenc/2, adec/2, pk/1-equations: adec(aenc(m, pk(k)), k) = m--/*-The above equation models the interaction between calls to these three-algorithms. All such user-specified  equations must be subterm-convergent-rewriting rules, when oriented from left to right. This means that the-right-hand-side must be a subterm of the left-hand-side or a nullary-function symbol.--Certain equational theories are used very often when modeling cryptographic-messages. We therefore provide builtins definitions for them. The above theory-could also be enabled using the declaration--  builtins: hashing, asymmetric-encryption--We support the following builtins theories:- -  diffie-hellman, signing, asymmetric-encryption, symmetric-encryption,-  hashing--Note that the theory for hashing only introduces the function symbol 'h/1'-and contains no equations.-Apart from 'diffie-hellman', all of these theories are subterm-convergent and-can therefore also be declared directly, as above. You can inspect their-definitions by uncommenting the following two line-comments and calling--  tamarin-prover Tutorial.spthy--*/--// builtins: diffie-hellman, signing, asymmetric-encryption, symmetric-encryption,-//          hashing--/*-The call 'tamarin-prover Tutorial.spthy' parses the Tutorial.spthy file,-computes the variants of the multiset rewriting rules, checks their-wellformedness (explained below), and pretty-prints the theory. The-declaration of the signature and the equations can be found at the top of the-pretty-printed theory.--Proving all lemmas contained in the theory is as simple as adding the-flag '--prove' to the call; i.e.,--  tamarin-prover Tutorial.spthy --prove--However, let's not go there yet. We first have to model the PKI and our-protocol.---Modeling the Public Key Infrastructure----------------------------------------*/--// Registering a public key-rule Register_pk:-  [ Fr(~ltk) ] -  --> -  [ !Ltk($A, ~ltk), !Pk($A, pk(~ltk)) ]--/* The above rule models registering a public key. It makes use of the-   following syntax.-   -   Facts always start with an upper-case letter and do not have to declared.-   If their name is prefixed with an exclamation mark '!', then they are-   persistent. Otherwise, they are linear. Note that you must use every fact-   name consistently; i.e., you must always use it with the same arity, casing,-   and multiplicity. Otherwise, the tamarin prover complains that the theory-   is not wellformed.--   The 'Fr' fact is a builtins fact. It denotes a freshly generated fresh name.-   See the paper for details.--   We denote the sort of variables using prefixes:--     ~x  denotes  x:fresh-     $x  denotes  x:pub-     #i  denotes  i:temp-     i   denotes  i:msg--     'c' denotes a public name 'c \in PN'; i.e., a fixed, global constant-   -   Thus, the above rule can be read as follows. First, freshly generate a-   fresh name 'ltk', the new private key and nondeterministically choose a-   public name 'A', the agent for which we are generating the key-pair.-   Then, generate the persistent fact !Ltk($A, ~ltk), which denotes the-   association between agent 'A' and its private key 'ltk, and generate the-   persistent fact !Pk($A, pk(~ltk)), which denotes the association between the-   agent 'A' and its public key 'pk(~ltk)'.--   We allow the adversary to retrieve any public key using the following rule.-   Intuitively, it just reads a public-key database entry and sends the public-   key to the network using the builtins fact 'Out' denoting a message sent to-   the network. See our paper for more information.-*/--rule Get_pk:-  [ !Pk(A, pk) ] -  --> -  [ Out(pk) ]--/*-   We model the dynamic compromise of long-term private keys using the following-   rule. Intuitively, it reads a private-key database entry and sends it to-   the adversary. This rule has an observable 'LtkReveal' action stating that-   the long-term key of agent 'A' was compromised. We will use this action in-   the security property below to determine which agents are compromised.-*/--rule Reveal_ltk:-    [ !Ltk(A, ltk) ]-  --[ LtkReveal(A) ]->-    [ Out(ltk) ]---/*--Modeling the protocol-------------------------Recall that we want to model the following protocol.--  C -> S: aenc{k}pk(S)-  C <- S: h(k)--We model it use the following three rules.-*/--// Start a new thread executing the client role, choosing the server-// non-deterministically.-rule Client_1:-    [ Fr(~k)         // choose fresh key-    , !Pk($S, pkS)   // lookup public-key of server-    ]-  -->-    [ Client_1( $S, ~k )       // Store server and key for next step of thread-    , Out( aenc{'1', ~k}pkS )  // Send the encrypted session key to the server-                               // We add the tag '1' to the request to allow-                               // the server to check whether the decryption-                               // was successful.-    ]--rule Client_2:-    [ Client_1(S, k)   // Retrieve server and session key from previous step-    , In( h(k) )       // Receive hashed session key from network-    ]-  --[ SessKeyC( S, k ) ]-> // State that the session key 'k'-    []                     // was setup with server 'S'--// A server thread answering in one-step to a session-key setup request from-// some client.-rule Serv_1:-    [ !Ltk($S, ~ltkS)                          // lookup the private-key-    , In( request )                            // receive a request-    ]-  --[ Eq(fst(adec(request, ~ltkS)), '1')-    , AnswerRequest($S, snd(adec(request, ~ltkS)))   // Explanation below-    ]->  -    [ Out( h(snd(adec(request, ~ltkS))) ) ]    // Return the hash of the-                                               // decrypted request.--/* Above, we model all applications of cryptographic algorithms explicitly.-   Call 'tamarin-prover Tutorial.spthy' to inspect the finite variants of the-   Serv_1 rule, which list all possible interactions of the destructors used.-   In our proof search, we will consider all these interactions.--   We also model that the server explicitly checks that the first component of-   the request is equal to '1'. We  model this by logging the claimed equality-   and then adapting the security property such that it only considers traces-   where all 'Eq' actions occur with two equal arguments. Note that 'Eq' is NO-   builtin fact. Guarded trace properties are strong enough to formalize this-   requirement without builtin support. Note that inequalities can be modeled-   analogously.--   We log the session-key setup requests received by servers to allow-   formalizing the authentication property for the client.---Modeling the security properties-----------------------------------The syntax for specifying security properties uses--  All      for universal quantification, temporal variables are prefixed with #-  Ex       for existential quantification, temporal variables are prefixed with #-  ==>      for implication-  &        for conjunction-  |        for disjunction-  not      for  negation-           -  f @ i    for action constraints, the sort prefix for the temporal variable 'i'-           is optional-           -  i < j    for temporal ordering, the sort prefix for the temporal variables 'i'-           adn 'j' is optional--  #i = #j  for an equality between temporal variables 'i' and 'j'-  x = y    for an equality between message variables 'x' and 'y'--Note that apart from public names (delimited using single-quotes), no terms-may occur in guarded trace properties. Moreover, all variables must be-guarded. The error message for an unguarded variable is currently not very-good. --For universally quantified variables, one has to check that they all occur in-an action constraint right after the quantifier and that the outermost logical operator-inside the quantifier is an implication.-For existentially quantified variables, one has to check that they all occur in-an action constraint right after the quantifier and that the outermost logical-operator inside the quantifier is a conjunction.-Note also that currently the precedence of the logical connectives is not-specified. We therefore recommend to use parentheses, when in doubt.---The following two properties should be self-explanatory.-*/--lemma Client_session_key_secrecy:-  "  /* For all traces, where all equality checks succeed, */-    (All x y #i. Eq(x,y) @ i ==> x = y)-  ==>-    /* it cannot be that a  */-    not(-      Ex S k #i #j.-        /* client setup a session key 'k' with a server'S' */-        SessKeyC(S, k) @ #i-        /* and the adversary knows 'k' */-      & K(k) @ #j-        /* without having performed a long-term key reveal on 'S'. */-      & not(Ex #r. LtkReveal(S) @ r) -    )-  "---lemma Client_auth:-  " /* For all traces, where all equality checks succeed, */-    (All x y #i. Eq(x,y) @ i ==> x = y)-  ==>-    /* for all session keys 'k' setup by clients with a server 'S' */-    ( All S k #i.  SessKeyC(S, k) @ #i-       ==>-         /* there is a server that answered the request */-       ( (Ex #a. AnswerRequest(S, k) @ a)-         /* or the intruder performed a long-term key reveal on 'S'-            before the key was setup. */-       | (Ex #r. LtkReveal(S) @ r & r < i)-       )-    )-  "--/*-  You can verify them by calling--    tamarin-prover --prove Tutorial.spthy--  This will first output some logging from the constraint solver and then the-  Tutorial security protocol theory with the lemmas and their attached-  (dis)proofs.--  Finding attacks is very useful, to check that a security property is not-  trivial due to too strong preconditions. The following property must not be-  provable, as otherwise there would be no possibility to setup a session key-  with a honest sever.--  We can check for the existence of a trace using the 'exists-trace'-  quantifier in front of the trace formula. When modeling protocols such-  existence proof are very useful sanity checks.-*/-lemma Client_session_key_honest_setup:-  exists-trace-  " (All x y #i. Eq(x,y) @ i ==> x = y)-  & (-      Ex S k #i.-        SessKeyC(S, k) @ #i-      & not(Ex #r. LtkReveal(S) @ r) -    )-  "--/*--Interactive proof visualization and construction---------------------------------------------------Just call --  tamarin-prover interactive Tutorial.spthy--This will start a web-server that loads all security protocol theories in the-same directory as Tutorial.spthy. Point your browser to--  http://localhost:3001--and explore the the Tutorial theory interactively by clicking on the-'Tutorial' entry in the table of loaded theories. You can prove a lemma-interactively by clicking on the available proof methods (corresponding to-applications of constraint reduction rules) or by calling the 'autoprover' by-right-clicking on a node in the theory overview. Note that that the proof-methods in the GUI are sorted according to our heuristic. Always selecting the-first proof method will result in the same proof as the ones constructed by-the 'autoprover' and '--prove'.---Conclusion-------------By now, you should have enough knowledge to understand the case studies from-our CSF'12 paper. Recall that you can find them in the directory listed at the-bottom of the help message, when calling 'tamarin-prover' without any-arguments. Note that Tamarin also outputs the path to the reference MANUAL-specifying and explaining the grammar of security protocol theories and giving-some additional hints on additional theory exploited by Tamarin.  If you have-further questions, please do not hesitate to contact either--  Benedikt Schmidt    benedikt.schmidt@inf.ethz.ch -  Simon Meier         simon.meier@inf.ethz.ch-  Cas Cremers         cas.cremers@inf.ethz.ch---BTW, every security protocol theory must be delimited with 'end'.--             (-: HAPPY PROVING :-)-*/--end
data/intruder_variants_dh.spthy view
@@ -1,10 +1,10 @@ rule (modulo AC) cexp:    [ !KU( 'exp', x ), !KU( f_.2, x.1 ) ]-  --[ Ded( x^x.1 ) ]->+  --[ !KU( 'noexp', x^x.1 ) ]->    [ !KU( 'noexp', x^x.1 ) ]  rule (modulo AC) cinv:-   [ !KU( f_.1, x ) ] --[ Ded( inv(x) ) ]-> [ !KU( 'exp', inv(x) ) ]+   [ !KU( f_.1, x ) ] --[ !KU( 'exp', inv(x) ) ]-> [ !KU( 'exp', inv(x) ) ]  rule (modulo AC) dexp:    [ !KD( 'exp', x.3^x.4 ), !KU( f_.2, x.1 ) ]
interactive-only-src/Paths_tamarin_prover.hs view
@@ -12,7 +12,7 @@   version :: Version-version = Version {versionBranch = [0,4,1,0], versionTags = []}+version = Version {versionBranch = [0,6,0,0], versionTags = []} bindir, libdir, datadir, libexecdir :: FilePath  bindir     = "./"
src/Main/Console.hs view
@@ -1,7 +1,7 @@ -- | -- Copyright   : (c) 2010, 2011 Benedikt Schmidt & Simon Meier -- License     : GPL v3 (see LICENSE)--- +-- -- Maintainer  : Simon Meier <iridcode@gmail.com> -- Portability : GHC only --@@ -42,18 +42,18 @@   , renderDoc   ) where -import           Safe import           Data.Maybe-import           Data.Version (showVersion)-                 +import           Data.Version                    (showVersion)+import           Safe+ import           Control.Monad-                 -import           System.FilePath+ import           System.Console.CmdArgs.Explicit import           System.Console.CmdArgs.Text import           System.Exit+import           System.FilePath -import qualified Text.PrettyPrint.Class as PP+import qualified Text.PrettyPrint.Class          as PP  import           Paths_tamarin_prover @@ -115,7 +115,7 @@ -- | Find the value corresponding to the given key. Throw an error if no value -- exists. getArg :: ArgKey -> Arguments -> ArgVal-getArg a = +getArg a =   fromMaybe (error $ "getArg: argument '" ++ a ++ "' not found") . findArg a  -- | Add an argument to the from of the list of arguments.@@ -151,16 +151,16 @@        }  -- | Smart constructor for a 'TamarinMode'.-tamarinMode :: String -> Help +tamarinMode :: String -> Help             -> (Mode Arguments -> Mode Arguments) -- ^ Changes to default mode.-            -> (TamarinMode -> Arguments -> IO ()) +            -> (TamarinMode -> Arguments -> IO ())             -> TamarinMode tamarinMode name help adaptMode run0 = TamarinMode   { tmName = name   , tmCmdArgsMode = adaptMode $ Mode       { modeGroupModes = toGroup []-      , modeNames      = [name] -      , modeValue      = [] +      , modeNames      = [name]+      , modeValue      = []       , modeCheck      = updateArg "mode" name       , modeReform     = const Nothing-- no reform possibility       , modeHelp       = help@@ -172,16 +172,16 @@   , tmIsMainMode = False   }   where-    run thisMode as +    run thisMode as       | argExists "help"    as = helpAndExit thisMode Nothing       | argExists "version" as = do licensePath <- getDataFileName "LICENSE"                                     putStrLn $ versionStr licensePath       | otherwise              = run0 thisMode as-    + -- | Disply help message of a tamarin mode and exit. helpAndExit :: TamarinMode -> Maybe String -> IO () helpAndExit tmode mayMsg = do-    putStrLn $ showText (Wrap lineWidth) +    putStrLn $ showText (Wrap lineWidth)              $ helpText header HelpFormatOne (tmCmdArgsMode tmode)     -- output example info     when (tmIsMainMode tmode) $ do@@ -189,11 +189,11 @@       manualPath  <- getDataFileName ("doc" </> "MANUAL")       let tutorialPath = examplePath </> "stable" </> "Tutorial.spthy"           csf12Path = examplePath </> "csf12" </> "*.spthy"-          csf12Cmd  = programName ++ " --prove -Ocase-studies +RTS -N -RTS " ++ csf12Path -          csf12Cmd' = programName ++ " interactive +RTS -N -RTS " ++ csf12Path +          csf12Cmd  = programName ++ " --prove -Ocase-studies +RTS -N -RTS " ++ csf12Path+          csf12Cmd' = programName ++ " interactive +RTS -N -RTS " ++ csf12Path           separator = replicate shortLineWidth '-'           e info paths = info ++ concatMap ("\n  " ++) paths ++ "\n"-      putStrLn $ unlines +      putStrLn $ unlines         [ separator         , e "For example protocol models see:" [examplePath]         , e "A tutorial and the user manul are found at" [tutorialPath, manualPath]@@ -225,7 +225,7 @@       , tmCmdArgsMode = (tmCmdArgsMode firstMode)           { modeNames = [programName]           , modeCheck      = updateArg "mode" programName-          , modeGroupModes = toGroup (map tmCmdArgsMode $ otherModes) +          , modeGroupModes = toGroup (map tmCmdArgsMode $ otherModes)           , modeGroupFlags = (modeGroupFlags $ tmCmdArgsMode firstMode)               { groupNamed =                   [ ("About"@@ -242,7 +242,7 @@ ------------------------------------------------------------------------------ -- Pretty printing -------------------------------------------------------------------------------       + -- | Render a pretty-printing document. renderDoc :: PP.Doc -> String-renderDoc = PP.renderStyle (PP.defaultStyle { PP.lineLength = lineWidth }) +renderDoc = PP.renderStyle (PP.defaultStyle { PP.lineLength = lineWidth })
src/Main/Environment.hs view
@@ -2,22 +2,22 @@ -- | -- Copyright   : (c) 2010, 2011 Benedikt Schmidt & Simon Meier -- License     : GPL v3 (see LICENSE)--- +-- -- Maintainer  : Simon Meier <iridcode@gmail.com> -- Portability : GHC only -- -- Helpers for inspecting the environment of the Tamarin prover. module Main.Environment where +import           Data.Char                       (isSpace, toLower) import           Data.List-import           Data.Char (isSpace, toLower)-import           Data.Maybe (fromMaybe)+import           Data.Maybe                      (fromMaybe) -import           Control.Exception as E+import           Control.Exception               as E  import           System.Console.CmdArgs.Explicit-import           System.Exit import           System.Environment+import           System.Exit import           System.IO import           System.Process @@ -31,7 +31,7 @@  -- | Flags for handing over the path to the maude and 'dot' tool. toolFlags :: [Flag Arguments]-toolFlags = +toolFlags =   [ flagOpt "dot" ["with-dot"] (updateArg "withDot") "FILE" "Path to GraphViz 'dot' tool"   , flagOpt "maude" ["with-maude"] (updateArg "withMaude") "FILE"  "Path to 'maude' rewriting tool"   ]@@ -57,7 +57,7 @@  -- | Read the cpu info using a call to cat /proc/cpuinfo getCpuModel :: IO String-getCpuModel = +getCpuModel =   handle handler $ do     (_, info, _) <- readProcessWithExitCode "cat" ["/proc/cpuinfo"] []     return $ maybe errMsg@@ -79,7 +79,7 @@  -- | Test if a process is executable and check its response. This is used to -- determine the versions and capabilities of tools that we depend on.-testProcess +testProcess   :: (String -> String -> Either String String)      -- ^ Analysis of stdout, stderr. Use 'Left' to report error.   -> String         -- ^ Default error message to display to the user.@@ -103,9 +103,9 @@                 return False          case exitCode of-            ExitFailure code -> errMsg $ +            ExitFailure code -> errMsg $               "failed with exit code " ++ show code ++ "\n\n" ++ defaultMsg-            ExitSuccess      -> +            ExitSuccess      ->               case check out err of                 Left msg     -> errMsg msg                 Right msg    -> do putStrLn msg@@ -145,7 +145,7 @@     return (t1 && t2)   where     maude = maudePath as-    checkVersion out _ +    checkVersion out _       | filter (not . isSpace) out == "2.6" = Right "2.6. OK."       | otherwise                           = Left  $ errMsg $           " 'maude --version' returned wrong verison '" ++ out ++ "'"
src/Main/Mode/Batch.hs view
@@ -2,7 +2,7 @@ -- | -- Copyright   : (c) 2010, 2011 Benedikt Schmidt & Simon Meier -- License     : GPL v3 (see LICENSE)--- +-- -- Maintainer  : Simon Meier <iridcode@gmail.com> -- Portability : GHC only --@@ -11,34 +11,34 @@     batchMode   ) where +import           Control.Basics import           Data.List import           Data.Maybe-import           Control.Basics import           System.Console.CmdArgs.Explicit as CmdArgs import           System.FilePath-import           System.Timing (timed)+import           System.Timing                   (timed) -import qualified Text.PrettyPrint.Class as Pretty+import qualified Text.PrettyPrint.Class          as Pretty  import           Theory -import           Main.Utils import           Main.Console import           Main.Environment import           Main.TheoryLoader+import           Main.Utils   -- | Batch processing mode. batchMode :: TamarinMode-batchMode = tamarinMode -    "batch" +batchMode = tamarinMode+    "batch"     "Security protocol analysis and verification."     setupFlags     run   where     setupFlags defaultMode = defaultMode       { modeArgs       = ([], Just $ flagArg (updateArg "inFile") "FILES")-      , modeGroupFlags = Group +      , modeGroupFlags = Group           { groupUnnamed =               theoryLoadFlags ++               -- [ flagNone ["html"] (addEmptyArg "html")@@ -51,20 +51,20 @@                   "Just parse the input file and pretty print it as-is"               ] ++               outputFlags ++-              toolFlags +              toolFlags           , groupHidden = []           , groupNamed = []           }       } -    outputFlags = +    outputFlags =       [ flagOpt "" ["output","o"] (updateArg "outFile") "FILE" "Output file"       , flagOpt "" ["Output","O"] (updateArg "outDir") "DIR"  "Output directory"       ]  -- | Process a theory file. run :: TamarinMode -> Arguments -> IO ()-run thisMode as +run thisMode as   | null inFiles = helpAndExit thisMode (Just "no input files given")   | otherwise    = do       _ <- ensureMaude as@@ -89,7 +89,7 @@      mkOutPath :: FilePath  -- ^ Input file name.               -> FilePath  -- ^ Output file name.-    mkOutPath inFile = +    mkOutPath inFile =         fromMaybe (error "please specify an output file or directory") $             do outFile <- findArg "outFile" as                guard (outFile /= "")@@ -108,12 +108,12 @@     ------------------------------      processThy :: FilePath -> IO (Pretty.Doc)-    processThy inFile  -      -- | argExists "html" as = +    processThy inFile+      -- | argExists "html" as =       --     generateHtml inFile =<< loadClosedThy as inFile       | argExists "parseOnly" as =           out (const Pretty.emptyDoc) prettyOpenTheory   (loadOpenThy   as inFile)-      | otherwise        = +      | otherwise        =           out prettyClosedSummary   prettyClosedTheory (loadClosedThy as inFile)       where         ppAnalyzed = Pretty.text $ "analyzed: " ++ inFile
src/Main/Mode/Interactive.hs view
@@ -2,7 +2,7 @@ -- | -- Copyright   : (c) 2010, 2011 Benedikt Schmidt & Simon Meier -- License     : GPL v3 (see LICENSE)--- +-- -- Maintainer  : Simon Meier <iridcode@gmail.com> -- Portability : GHC only --@@ -11,32 +11,31 @@     interactiveMode   ) where +import           Control.Basics+import           Control.Exception               (handle, IOException)+import           Data.Char                       (toLower) import           Data.List import           Data.Maybe-import           Data.String (fromString)-import           Data.Char (toLower)-import           Control.Basics-import           Control.Exception (handle, IOException)+import           Data.String                     (fromString) import           System.Console.CmdArgs.Explicit as CmdArgs+import           System.Directory                (doesFileExist, doesDirectoryExist) import           System.FilePath-import           System.Directory (doesFileExist, doesDirectoryExist) +import           Network.Wai.Handler.Warp        (defaultSettings, settingsHost, settingsPort)+import qualified Network.Wai.Handler.Warp        as Warp import           Web.Dispatch import qualified Web.Settings-import qualified Network.Wai.Handler.Warp as Warp-import           Network.Wai.Handler.Warp (defaultSettings, settingsHost-                                          , settingsPort, HostPreference(Host))  import           Main.Console import           Main.Environment import           Main.TheoryLoader -import           Paths_tamarin_prover (getDataDir)+import           Paths_tamarin_prover            (getDataDir)   -- | Batch processing mode. interactiveMode :: TamarinMode-interactiveMode = tamarinMode +interactiveMode = tamarinMode     "interactive"     "Start a web-server to construct proofs interactively."     setupFlags@@ -52,7 +51,7 @@       [ flagOpt "" ["port","p"] (updateArg "port") "PORT" "Port to listen on"       , flagOpt "" ["interface","i"] (updateArg "interface") "INTERFACE"                 "Interface to listen on (use '*4' for all IPv4 interfaces)"-      , flagOpt "" ["image-format"] (updateArg "image-format") "PNG|SVG" "image format used for graphs"+      , flagOpt "" ["image-format"] (updateArg "image-format") "PNG|SVG" "image format used for graphs (default PNG)"       , flagNone ["debug"] (addEmptyArg "debug") "Show server debugging output"       -- , flagNone ["autosave"] (addEmptyArg "autosave") "Automatically save proof state"       -- , flagNone ["loadstate"] (addEmptyArg "loadstate") "Load proof state if present"@@ -60,8 +59,8 @@       theoryLoadFlags ++       toolFlags -  + -- | Start the interactive theorem proving mode. run :: TamarinMode -> Arguments -> IO () run thisMode as = case findArg "workDir" as of@@ -81,20 +80,21 @@           putStrLn ""           port <- readPort           dataDir <- getDataDir-          let webUrl = serverUrl (fromString interface) port+          let webUrl = serverUrl port           putStrLn $ intercalate "\n"             [ "The server is starting up on port " ++ show port ++ "."             , "Browse to " ++ webUrl ++ " once the server is ready."             , ""             , "Loading the security protocol theories '" ++ workDir </> "*.spthy"  ++ "' ..."             ]-          withWebUI +          withWebUI             ("Finished loading theories ... server ready at \n\n    " ++ webUrl ++ "\n")             workDir (argExists "loadstate" as) (argExists "autosave" as)             (loadClosedWfThy as) (loadClosedThyString as) (closeThy as)             (argExists "debug" as) dataDir (dotPath as) readImageFormat+            (constructAutoProver as)             (runWarp port)-        else +        else           helpAndExit thisMode             (Just $ "directory '" ++ workDir ++ "' does not exist.")   where@@ -104,7 +104,7 @@     readPort = do       let port = findArg "port" as >>= fmap fst . listToMaybe . reads       when-        (argExists "port" as && isNothing port) +        (argExists "port" as && isNothing port)         (putStrLn $ "Unable to read port from argument `"                     ++ fromMaybe "" (findArg "port" as) ++ "'. Using default.")       return $ fromMaybe Web.Settings.defaultPort port@@ -119,11 +119,10 @@                           Nothing    -> PNG                           _          -> error "image-format must be one of PNG|SVG" -    serverUrl host port = "http://" ++ hostString ++ ":" ++ show port+    serverUrl port = "http://" ++ address ++ ":" ++ show port       where-        hostString = case host of-                         Host s -> s-                         _      -> "127.0.0.1" -- 127.0.0.1 should work for HostAny..+        address | interface `elem` ["*","*4","*6"] = "127.0.0.1"+                | otherwise                        = interface      runWarp port wapp =         handle (\e -> err (e::IOException))
src/Main/Mode/Intruder.hs view
@@ -2,7 +2,7 @@ -- | -- Copyright   : (c) 2010, 2011 Benedikt Schmidt & Simon Meier -- License     : GPL v3 (see LICENSE)--- +-- -- Maintainer  : Simon Meier <iridcode@gmail.com> -- Portability : GHC only --@@ -11,23 +11,24 @@     intruderMode   ) where -import Control.Basics-import Control.Monad.Reader+import           Control.Basics+import           Control.Monad.Reader -import System.Console.CmdArgs.Explicit as CmdArgs-import System.FilePath+import           System.Console.CmdArgs.Explicit as CmdArgs+import           System.FilePath -import Theory+import           Theory+import           Theory.Tools.IntruderRules -import Main.Console-import Main.Environment-import Main.TheoryLoader (intruderVariantsFile)-import Main.Utils+import           Main.Console+import           Main.Environment+import           Main.TheoryLoader               (intruderVariantsFile)+import           Main.Utils   intruderMode :: TamarinMode-intruderMode = tamarinMode -    "variants" +intruderMode = tamarinMode+    "variants"     "Compute the variants of the intruder rules for DH-exponentiation."     setupFlags     run@@ -37,7 +38,7 @@       , modeGroupFlags = Group outputFlags [] [("About", [helpFlag])]       } -    outputFlags = +    outputFlags =       [ flagOpt "" ["output","o"] (updateArg "outFile") "FILE" "Output file"       , flagOpt "" ["Output","O"] (updateArg "outDir") "DIR"  "Output directory"       ]@@ -61,10 +62,10 @@      -- Output file name, if output is desired.     optOutPath :: Maybe FilePath-    optOutPath = +    optOutPath =       do outFile <- findArg "outFile" as          guard (outFile /= "")          return outFile       <|>       do outDir <- findArg "outDir" as-         return $ outDir </> intruderVariantsFile +         return $ outDir </> intruderVariantsFile
src/Main/Mode/Test.hs view
@@ -2,7 +2,7 @@ -- | -- Copyright   : (c) 2010, 2011 Benedikt Schmidt & Simon Meier -- License     : GPL v3 (see LICENSE)--- +-- -- Maintainer  : Simon Meier <iridcode@gmail.com> -- Portability : GHC only --@@ -13,26 +13,26 @@  import           System.Console.CmdArgs.Explicit as CmdArgs import           System.Exit-import           Test.HUnit (Counts(..))+import           Test.HUnit                      (Counts(..))  import           Main.Console import           Main.Environment -import qualified Term.UnitTests as TestTerm (main)+import qualified Term.UnitTests                  as TestTerm (main)   -- | Self-test mode. testMode :: TamarinMode-testMode = tamarinMode -    "test" +testMode = tamarinMode+    "test"     ("Self-test the " ++ programName ++ " installation.")     setupFlags     run   where     setupFlags defaultMode = defaultMode       { modeArgs       = ([], Just $ flagArg (updateArg "inFile") "FILES")-      , modeGroupFlags = Group -          { groupUnnamed = toolFlags +      , modeGroupFlags = Group+          { groupUnnamed = toolFlags           , groupHidden  = []           , groupNamed   = [("About", [helpFlag])]           }@@ -41,7 +41,7 @@ -- | Run the self-test. run :: TamarinMode -> Arguments -> IO () run _thisMode as = do-    putStrLn $ "Self-testing the " ++ programName ++ " installation." +    putStrLn $ "Self-testing the " ++ programName ++ " installation."     nextTopic "Testing the availability of the required tools"     successMaude <- ensureMaude as #ifndef NO_GUI
src/Main/TheoryLoader.hs view
@@ -2,7 +2,7 @@ -- | -- Copyright   : (c) 2010, 2011 Benedikt Schmidt & Simon Meier -- License     : GPL v3 (see LICENSE)--- +-- -- Maintainer  : Simon Meier <iridcode@gmail.com> -- Portability : GHC only --@@ -20,18 +20,22 @@   , loadClosedWfThy   , loadClosedThyString +  -- ** Constructing automatic provers+  , constructAutoProver+   , closeThy    ) where -import           Prelude hiding (id, (.))+import           Prelude                             hiding (id, (.)) -import           Data.Monoid-import           Data.Char (toLower)+import           Data.Char                           (toLower) import           Data.Label+import           Data.Monoid  import           Control.Basics import           Control.Category+import           Control.DeepSeq (rnf)  import           System.Console.CmdArgs.Explicit import           System.Directory@@ -39,14 +43,16 @@ import           Extension.Prelude  import           Theory-import           Theory.Parser-import           Theory.Wellformedness-import           Theory.AbstractInterpretation (EvaluationStyle(..))+import           Theory.Text.Parser+import           Theory.Text.Pretty+import           Theory.Tools.AbstractInterpretation (EvaluationStyle(..))+import           Theory.Tools.IntruderRules+import           Theory.Tools.Wellformedness  import           Main.Console import           Main.Environment -import           Paths_tamarin_prover (getDataFileName)+import           Paths_tamarin_prover                (getDataFileName)   ------------------------------------------------------------------------------@@ -60,16 +66,19 @@  -- | Flags for loading a theory. theoryLoadFlags :: [Flag Arguments]-theoryLoadFlags = +theoryLoadFlags =   [ flagNone ["prove"] (addEmptyArg "addProofs")       "Attempt to prove all security properties"    , flagOpt "dfs" ["stop-on-trace"] (updateArg "stopOnTrace") "DFS|BFS|NONE"       "How to search for traces (default DFS)" -  , flagOpt "5" ["bound", "b"]   (updateArg "bound") "INT"+  , flagOpt "5" ["bound", "b"] (updateArg "bound") "INT"       "Bound the depth of the proofs" +  , flagOpt "s" ["heuristic"] (updateArg "heuristic") "(s|S|c|C)+"+      "Sequence of goal rankings to use (default 's')"+   --, flagOpt "" ["intruder","i"] (updateArg "intruderVariants") "FILE"   --    "Cached intruder rules to use" @@ -92,7 +101,7 @@     thy <- loadOpen file     case checkWellformedness thy of       []     -> close thy-      report -> do +      report -> do           putStrLn $ "WARNING: ignoring the following errors"           putStrLn $ renderDoc $ prettyWfErrorReport report           close thy@@ -105,7 +114,7 @@  -- | Load an open/closed theory from a file. loadThy :: Arguments -> (FilePath -> IO OpenTheory, OpenTheory -> IO ClosedTheory)-loadThy as = loadGenericThy (parseOpenTheory (defines as)) as +loadThy as = loadGenericThy (parseOpenTheory (defines as)) as  -- | Load an open/closed theory from a string. loadThyString :: Arguments -> (String -> IO OpenTheory, OpenTheory -> IO ClosedTheory)@@ -114,7 +123,7 @@     loader str =       case parseOpenTheoryString (defines as) str of         Right thy -> return thy-        Left err -> error $ show err +        Left err -> error $ show err  -- | The defined pre-processor flags in the argument. defines :: Arguments -> [String]@@ -122,7 +131,7 @@  -- | Load an open/closed theory given a loader function. loadGenericThy :: (a -> IO OpenTheory)-               -> Arguments +               -> Arguments                -> (a -> IO OpenTheory, OpenTheory -> IO ClosedTheory) loadGenericThy loader as =     (loader, (closeThy as) <=< tryAddIntrVariants)@@ -139,27 +148,20 @@                 (do intrVariants <- parseIntruderRulesDH variantsFile                     return $ addIntrRuleACs intrVariants thy                 )-                (error $ "could not find intruder message deduction theory '" +                (error $ "could not find intruder message deduction theory '"                            ++ variantsFile ++ "'")          else return thy  -- | Close a theory according to arguments. closeThy :: Arguments -> OpenTheory -> IO ClosedTheory-closeThy as = -      fmap (proveTheory prover . partialEvaluation) +closeThy as =+      fmap (proveTheory prover . partialEvaluation)     . closeTheory (maudePath as)     -- FIXME: wf-check is at the wrong position here. Needs to be more     -- fine-grained.-    . wfCheck +    . wfCheck   where-    -- handles to relevant arguments-    ---------------------------------    proofBound      = read <$> findArg "bound" as-    requireProofs   = argExists "addProofs" as -    stopOnTrace :: Maybe String-    stopOnTrace = findArg "stopOnTrace" as-     -- apply partial application     ----------------------------     partialEvaluation = case map toLower <$> findArg "partialEvaluation" as of@@ -170,21 +172,45 @@     -- wellformedness check     -----------------------     wfCheck :: OpenTheory -> OpenTheory-    wfCheck thy = +    wfCheck thy =       noteWellformedness         (checkWellformedness thy) thy -    -- protocol transformation-    --------------------------     prover :: Prover-    prover -       | requireProofs = cutAttack $ maybe id boundProver proofBound autoProver-       | otherwise     = mempty-       where -         cutAttack = mapProverProof $ case map toLower <$> stopOnTrace of-           Nothing     -> cutOnAttackDFS-           Just "dfs"  -> cutOnAttackDFS-           Just "none" -> id-           Just "bfs"  -> cutOnAttackBFS-           Just other  -> error $ "unknown stop-on-trace method: " ++ other+    prover | argExists "addProofs" as = runAutoProver $ constructAutoProver as+           | otherwise                = mempty +-- | Construct an 'AutoProver' from the given arguments (--bound,+-- --stop-on-trace).+constructAutoProver :: Arguments -> AutoProver+constructAutoProver as =+    -- force error early+    (rnf rankings) `seq`+    AutoProver (roundRobinHeuristic rankings) proofBound stopOnTrace+  where+    -- handles to relevant arguments+    --------------------------------+    proofBound      = read <$> findArg "bound" as++    rankings = case findArg "heuristic" as of+        Just (rawRankings@(_:_)) -> map ranking rawRankings+        Just []                  -> error "--heuristic: at least one ranking must be given"+        _                        -> [SmartRanking False]++    ranking 's' = SmartRanking False+    ranking 'S' = SmartRanking True+    ranking 'c' = UsefulGoalNrRanking+    ranking 'C' = GoalNrRanking+    ranking r   = error $ render $ fsep $ map text $ words $+      "Unknown goal ranking '" ++ [r] ++ "'. Use one of the following:\+      \ 's' for the smart ranking without loop breakers,\+      \ 'S' for the smart ranking with loop breakers,\+      \ 'c' for the creation order and useful goals first,\+      \ and 'C' for the creation order."++    stopOnTrace = case (map toLower) <$> findArg "stopOnTrace" as of+      Nothing     -> CutDFS+      Just "dfs"  -> CutDFS+      Just "none" -> CutNothing+      Just "bfs"  -> CutBFS+      Just other  -> error $ "unknown stop-on-trace method: " ++ other
src/Main/Utils.hs view
@@ -1,7 +1,7 @@ -- | -- Copyright   : (c) 2012 Simon Meier -- License     : GPL v3 (see LICENSE)--- +-- -- Maintainer  : Simon Meier <iridcode@gmail.com> -- -- Various utility functions for interacting with the user.
src/Theory.hs view
@@ -3,7 +3,7 @@ -- | -- Copyright   : (c) 2010-2012 Benedikt Schmidt & Simon Meier -- License     : GPL v3 (see LICENSE)--- +-- -- Maintainer  : Simon Meier <iridcode@gmail.com> -- Portability : GHC only --@@ -19,7 +19,7 @@   , lFormulaAC   , lAttributes   , lProof-  , unprovenLemma +  , unprovenLemma   , skeletonLemma    -- * Theories@@ -64,7 +64,6 @@   -- ** Proving   , ProofSkeleton   , proveTheory-  , applicableProofMethods    -- ** Lemma references   , lookupLemmaProof@@ -83,48 +82,39 @@   , prettyTraceQuantifier    -- * Convenience exports+  , module Theory.Model   , module Theory.Proof-  , module Theory.IntruderRules-  +   ) where -import           Prelude hiding ( (.), id )-                 -import           Data.Maybe-import           Data.Monoid (Sum(..))-import qualified Data.Set as S-import           Data.List-import           Data.Foldable (Foldable, foldMap)-import           Data.Traversable (Traversable, traverse)-import           Data.DeriveTH+import           Prelude                             hiding ( (.), id )+ import           Data.Binary-                 +import           Data.DeriveTH+import           Data.Foldable                       (Foldable, foldMap)+import           Data.List+import           Data.Maybe+import           Data.Monoid                         (Sum(..))+import qualified Data.Set                            as S+import           Data.Traversable                    (Traversable, traverse)+ import           Control.Basics-import           Control.Parallel.Strategies-import           Control.DeepSeq import           Control.Category-import qualified Control.Monad.State     as MS+import           Control.DeepSeq import           Control.Monad.Reader+import qualified Control.Monad.State                 as MS+import           Control.Parallel.Strategies -import qualified Extension.Data.Label    as L-import           Extension.Data.Label    hiding (get)+import           Extension.Data.Label                hiding (get)+import qualified Extension.Data.Label                as L -import           Theory.Pretty-import           Theory.Rule-import           Theory.RuleSet-import           Theory.RuleVariants-import           Theory.IntruderRules+import           Theory.Model import           Theory.Proof-import           Theory.AbstractInterpretation------------------------------------------------------------------------------------ To MOVE----------------------------------------------------------------------------------- | Vertically separate a list of documents by empty lines.-vsep :: Document d => [d] -> d-vsep = foldr ($--$) emptyDoc+import           Theory.Text.Pretty+import           Theory.Tools.AbstractInterpretation+import           Theory.Tools.LoopBreakers+import           Theory.Tools.RuleVariants+import           Theory.Tools.UniqueFactInstances   ------------------------------------------------------------------------------@@ -155,7 +145,7 @@  -- | A closed proto rule lists its original rule modulo E, the corresponding -- variant modulo AC, and if required the assertion soundness proof.-data ClosedProtoRule = ClosedProtoRule +data ClosedProtoRule = ClosedProtoRule        { _cprRuleE  :: ProtoRuleE             -- original rule modulo E        , _cprRuleAC :: ProtoRuleAC            -- variant modulo AC        }@@ -167,6 +157,7 @@        { _crcRules            :: ClassifiedRules        , _crcUntypedCaseDists :: [CaseDistinction]        , _crcTypedCaseDists   :: [CaseDistinction]+       , _crcUniqueFactInsts  :: S.Set FactTag        }        deriving( Eq, Ord, Show ) @@ -201,23 +192,30 @@  -- | Close a rule cache. Hower, note that the -- requires case distinctions are not computed here.-closeRuleCache :: [LNGuarded]        -- ^ Typing lemmas.+closeRuleCache :: [FormulaAC]        -- ^ Typing lemmas.                -> SignatureWithMaude -- ^ Signature of theory.                -> [ClosedProtoRule]  -- ^ Protocol rules with variants.                -> OpenRuleCache      -- ^ Intruder rules modulo AC.                -> ClosedRuleCache    -- ^ Cached rules and case distinctions.-closeRuleCache typingAsms sig protoRules intrRulesAC = -    ClosedRuleCache classifiedRules untypedCaseDists typedCaseDists+closeRuleCache typingAsms sig protoRules intrRulesAC =+    ClosedRuleCache+        classifiedRules untypedCaseDists typedCaseDists uniqueFactInsts   where-    ctxt0 = ProofContext sig classifiedRules UntypedCaseDist [] AvoidInduction-                         (error "closeRuleCache: trace quantifier should not matter here")+    ctxt0 = ProofContext+        sig classifiedRules uniqueFactInsts UntypedCaseDist [] AvoidInduction+        (error "closeRuleCache: trace quantifier should not matter here")++    -- unique fact instances+    uniqueFactInsts =+        simpleUniqueFactInstances $ L.get cprRuleE <$> protoRules+     -- precomputing the case distinctions-    untypedCaseDists = precomputeCaseDistinctions ctxt0 [] -    typedCaseDists   = +    untypedCaseDists = precomputeCaseDistinctions ctxt0 []+    typedCaseDists   =         refineWithTypingAsms typingAsms ctxt0 untypedCaseDists      -- classifying the rules-    rulesAC = (fmap IntrInfo                      <$> intrRulesAC) <|> +    rulesAC = (fmap IntrInfo                      <$> intrRulesAC) <|>               ((fmap ProtoInfo . L.get cprRuleAC) <$> protoRules)      anyOf ps = partition (\x -> any ($ x) ps)@@ -239,7 +237,7 @@ ------------------------------------------------------------------------------  -- | An attribute for a 'Lemma'.-data LemmaAttribute = +data LemmaAttribute =          TypingLemma        | ReuseLemma        | InvariantLemma@@ -281,9 +279,9 @@ ----------------------------------  -- | Convert a trace quantifier to a sequent trace quantifier.-toSequentTraceQuantifier :: TraceQuantifier -> SequentTraceQuantifier-toSequentTraceQuantifier AllTraces   = ExistsNoTrace-toSequentTraceQuantifier ExistsTrace = ExistsSomeTrace+toSystemTraceQuantifier :: TraceQuantifier -> SystemTraceQuantifier+toSystemTraceQuantifier AllTraces   = ExistsNoTrace+toSystemTraceQuantifier ExistsTrace = ExistsSomeTrace  -- | True iff the lemma can be used as a typing lemma. isTypingLemma :: Lemma p -> Bool@@ -309,8 +307,8 @@ lemmaCaseDistKind lem   | TypingLemma `elem` L.get lAttributes lem = UntypedCaseDist   | otherwise                                = TypedCaseDist-    + ------------------------------------------------------------------------------ -- Theories ------------------------------------------------------------------------------@@ -319,7 +317,7 @@ type FormalComment = (String, String)  -- | A theory item built over the given rule type.-data TheoryItem r p = +data TheoryItem r p =        RuleItem r      | LemmaItem (Lemma p)      | TextItem FormalComment@@ -327,7 +325,7 @@   -- | A theory contains a single set of rewriting rules modeling a protocol--- and the lemmas that +-- and the lemmas that data Theory sig c r p = Theory {          _thyName      :: String        , _thySignature :: sig@@ -338,9 +336,9 @@ $(mkLabels [''Theory])  -- | Open theories can be extended. Invariants:---   1. Lemma names are unique. -type OpenTheory = -    Theory SignaturePure [IntrRuleAC] OpenProtoRule ProofSkeleton +--   1. Lemma names are unique.+type OpenTheory =+    Theory SignaturePure [IntrRuleAC] OpenProtoRule ProofSkeleton  deriving instance Show OpenTheory @@ -349,7 +347,7 @@ --     2. All proof steps with annotated sequents are sound with respect to the --        closed rule set of the theory. --     3. Maude is running under the given handle.-type ClosedTheory = +type ClosedTheory =     Theory SignatureWithMaude ClosedRuleCache ClosedProtoRule IncrementalProof  deriving instance Show ClosedTheory@@ -359,7 +357,7 @@ ---------------------------------------  -- | Fold a theory item.-foldTheoryItem :: (r -> a) -> (Lemma p -> a) -> (FormalComment -> a) +foldTheoryItem :: (r -> a) -> (Lemma p -> a) -> (FormalComment -> a)                -> TheoryItem r p -> a foldTheoryItem fRule fLemma fText i = case i of     RuleItem r  -> fRule r@@ -399,14 +397,14 @@  -- | Add a comment to the theory. addComment :: Doc -> Theory sig c r p -> Theory sig c r p-addComment c = modify thyItems (++ [TextItem ("", render c)]) +addComment c = modify thyItems (++ [TextItem ("", render c)])  -- | Add a comment represented as a string to the theory. addStringComment :: String -> Theory sig c r p -> Theory sig c r p addStringComment = addComment . vcat . map text . lines  addFormalComment :: FormalComment -> Theory sig c r p -> Theory sig c r p-addFormalComment c = modify thyItems (++ [TextItem c]) +addFormalComment c = modify thyItems (++ [TextItem c])   ------------------------------------------------------------------------------@@ -420,20 +418,20 @@ -- | Open a theory by dropping the closed world assumption and values whose -- soundness dependens on it. openTheory :: ClosedTheory -> OpenTheory-openTheory  (Theory n sig c items) = -    Theory n (toSignaturePure sig) (openRuleCache c) +openTheory  (Theory n sig c items) =+    Theory n (toSignaturePure sig) (openRuleCache c)       (map (mapTheoryItem openProtoRule incrementalToSkeletonProof) items)  -- | Find the open protocol rule with the given name. lookupOpenProtoRule :: ProtoRuleName -> OpenTheory -> Maybe OpenProtoRule-lookupOpenProtoRule name = +lookupOpenProtoRule name =     find ((name ==) . L.get rInfo) . theoryRules  -- | Add a new protocol rules. Fails, if a protocol rule with the same name -- exists. addProtoRule :: ProtoRuleE -> OpenTheory -> Maybe OpenTheory addProtoRule ruE thy = do-    guard (maybe True ((ruE ==)) $ +    guard (maybe True ((ruE ==)) $         lookupOpenProtoRule (L.get rInfo ruE) thy)     return $ modify thyItems (++ [RuleItem ruE]) thy @@ -459,17 +457,18 @@  -- | All protocol rules modulo E. getProtoRuleEs :: ClosedTheory -> [ProtoRuleE]-getProtoRuleEs = map openProtoRule . theoryRules +getProtoRuleEs = map openProtoRule . theoryRules  -- | Get the proof context for a lemma of the closed theory. getProofContext :: Lemma a -> ClosedTheory -> ProofContext getProofContext l thy = ProofContext-    ( L.get thySignature          thy)-    ( L.get (crcRules . thyCache) thy)+    ( L.get thySignature                    thy)+    ( L.get (crcRules . thyCache)           thy)+    ( L.get (crcUniqueFactInsts . thyCache) thy)     kind-    ( L.get (cases . thyCache)    thy)+    ( L.get (cases . thyCache)              thy)     inductionHint-    (toSequentTraceQuantifier $ L.get lTraceQuantifier l)+    (toSystemTraceQuantifier $ L.get lTraceQuantifier l)   where     kind    = lemmaCaseDistKind l     cases   = case kind of UntypedCaseDist -> crcUntypedCaseDists@@ -493,14 +492,14 @@  -- -- | Convert a lemma to the corresponding guarded formula. -- lemmaToGuarded :: Lemma p -> Maybe LNGuarded--- lemmaToGuarded lem = +-- lemmaToGuarded lem =  -- | Close a theory by closing its associated rule set and converting the proof -- skeletons to unannotated incremental proofs and caching AC variants as well -- as precomputed case distinctions.--- +-- -- This function initializes the relation to the Maude process with the--- correct signature. This is the right place to do that because in a closed +-- correct signature. This is the right place to do that because in a closed -- theory the signature may not change any longer. closeTheory :: FilePath         -- ^ Path to the Maude executable.             -> OpenTheory@@ -524,20 +523,16 @@     -- close all theory items: in parallel     (items, _solveRel, _breakers) = (`runReader` hnd) $ addSolvingLoopBreakers        ((closeTheoryItem <$> L.get thyItems thy0) `using` parList rdeepseq)-    closeTheoryItem = foldTheoryItem -       (RuleItem . closeProtoRule hnd) +    closeTheoryItem = foldTheoryItem+       (RuleItem . closeProtoRule hnd)        (LemmaItem . ensureFormulaAC . fmap skeletonToIncrementalProof)        TextItem      -- extract typing lemmas-    typAsms = do +    typAsms = do         LemmaItem lem <- items-        guard (isTypingLemma lem) -        let toGuarded = fmap negateGuarded . fromFormulaNegate-        case toGuarded <$> L.get lFormulaAC lem of-          Just (Right gf) -> return gf-          Just (Left err) -> error $ "closeTheory: " ++ err-          _               -> mzero+        guard (isTypingLemma lem)+        maybe [] return $ L.get lFormulaAC lem      -- extract protocol rules     rules = theoryRules (Theory errClose errClose errClose items)@@ -552,7 +547,7 @@         liftToItem f (RuleItem ru) = f ru         liftToItem _ _             = [] -        addBreakers bs (RuleItem ru) = +        addBreakers bs (RuleItem ru) =             RuleItem (L.set (pracLoopBreakers . rInfo . cprRuleAC) bs ru)         addBreakers _  item = item @@ -569,25 +564,25 @@   where     sig          = L.get thySignature thy0     ruEs         = getProtoRuleEs thy0-    (st', ruEs') = (`runReader` L.get sigmMaudeHandle sig) $ +    (st', ruEs') = (`runReader` L.get sigmMaudeHandle sig) $                    partialEvaluation evalStyle ruEs      replaceProtoRules [] = []     replaceProtoRules (item:items)-      | isRuleItem item  = +      | isRuleItem item  =           [ TextItem ("text", render ppAbsState)-              +           ] ++ map RuleItem ruEs' ++ filter (not . isRuleItem) items       | otherwise        = item : replaceProtoRules items      isRuleItem (RuleItem _) = True     isRuleItem _            = False -    ppAbsState = -      (text $ " the abstract state after partial evaluation" +    ppAbsState =+      (text $ " the abstract state after partial evaluation"               ++ " contains " ++ show (S.size st') ++ " facts:") $--$       (numbered' $ map prettyLNFact $ S.toList st') $--$-      (text $ "This abstract state results in " ++ show (length ruEs') ++ +      (text $ "This abstract state results in " ++ show (length ruEs') ++               " refined multiset rewriting rules.\n" ++               "Note that the original number of multiset rewriting rules was "               ++ show (length ruEs) ++ ".\n\n")@@ -595,17 +590,10 @@ -- Applying provers ------------------- --- | A list of proof methods that could be applied to the given sequent.-applicableProofMethods :: ProofContext -> Sequent -> [ProofMethod]-applicableProofMethods ctxt se = do-    m <- possibleProofMethods ctxt se-    guard (isJust $ execProofMethod ctxt m se)-    return m- -- | Prove both the assertion soundness as well as all lemmas of the theory. If -- the prover fails on a lemma, then its proof remains unchanged. proveTheory :: Prover -> ClosedTheory -> ClosedTheory-proveTheory prover thy = +proveTheory prover thy =     modify thyItems ((`MS.evalState` []) . mapM prove) thy   where     prove item = case item of@@ -618,31 +606,29 @@         modify lProof add l       where         l       = ensureFormulaAC l0-        ctxt    = getProofContext l thy -        se      = formulaToSequent ctxt preItems $ fromJust $ L.get lFormulaAC l-        add prf = fromMaybe prf $ runProver prover ctxt se prf+        ctxt    = getProofContext l thy+        sys     = mkSystem ctxt preItems $ fromJust $ L.get lFormulaAC l+        add prf = fromMaybe prf $ runProver prover ctxt 0 sys prf --- | Convert a formula modulo AC to a sequent.-formulaToSequent :: ProofContext -> [TheoryItem r p] -> FormulaAC -> Sequent-formulaToSequent ctxt lems = -    addLemmasToSequent lems -  . sequentFromFormula (L.get pcCaseDistKind ctxt) (L.get pcTraceQuantifier ctxt)+-- | Construct a constraint system for verifying the given formula.+mkSystem :: ProofContext -> [TheoryItem r p] -> FormulaAC -> System+mkSystem ctxt lems =+    addLemmasToSystem lems+  . formulaToSystem (L.get pcCaseDistKind ctxt) (L.get pcTraceQuantifier ctxt)  -- | Add the lemmas that have an associated AC variant to this sequent.-addLemmasToSequent :: [TheoryItem r p] -> Sequent -> Sequent-addLemmasToSequent items se = -    modify sLemmas (S.union gfs) se -  where-    gfs = S.fromList $ gatherReusableLemmas (L.get sCaseDistKind se) items+addLemmasToSystem :: [TheoryItem r p] -> System -> System+addLemmasToSystem items sys =+    foldl' (flip insertLemma) sys $+    gatherReusableLemmas (L.get sCaseDistKind sys) items  -- | Gather reusable lemmas to be added to a sequent.-gatherReusableLemmas :: CaseDistKind -> [TheoryItem r p] -> [LNGuarded]+gatherReusableLemmas :: CaseDistKind -> [TheoryItem r p] -> [LNFormula] gatherReusableLemmas kind items = do     LemmaItem lem <- items-    guard $ lemmaCaseDistKind lem <= kind && +    guard $ lemmaCaseDistKind lem <= kind &&             ReuseLemma `elem` L.get lAttributes lem-    Just (Right gf) <- [fromFormula <$> L.get lFormulaAC lem]-    return gf+    maybe [] return $ L.get lFormulaAC lem  -- | Ensure that the AC variant of a formula is present. ensureFormulaAC :: Lemma p -> Lemma p@@ -661,14 +647,14 @@ -- | Lemmas are referenced by their name. type LemmaRef = String --- | Resolve a path in a theory. +-- | Resolve a path in a theory. lookupLemmaProof :: LemmaRef -> ClosedTheory -> Maybe IncrementalProof lookupLemmaProof name thy = L.get lProof <$> lookupLemma name thy  -- | Modify the proof at the given lemma ref, if there is one. Fails if the -- path is not present or if the prover fails. modifyLemmaProof :: Prover -> LemmaRef -> ClosedTheory -> Maybe ClosedTheory-modifyLemmaProof prover name thy = +modifyLemmaProof prover name thy =     modA thyItems changeItems thy   where     findLemma (LemmaItem lem) = name == L.get lName lem@@ -677,8 +663,8 @@     change preItems (LemmaItem l0) = do          let l1   = ensureFormulaAC l0              ctxt = getProofContext l1 thy-         se <- formulaToSequent ctxt preItems <$> L.get lFormulaAC l1-         l2 <- modA lProof (runProver prover ctxt se) l1+         sys <- mkSystem ctxt preItems <$> L.get lFormulaAC l1+         l2  <- modA lProof (runProver prover ctxt 0 sys) l1          return $ LemmaItem l2     change _ _ = error "LemmaProof: change: impossible" @@ -699,19 +685,19 @@ prettyFormalComment header body = text $ header ++ "{*" ++ body ++ "*}"  -- | Pretty print a theory.-prettyTheory :: HighlightDocument d +prettyTheory :: HighlightDocument d              => (sig -> d) -> (c -> d) -> (r -> d) -> (p -> d)              -> Theory sig c r p -> d prettyTheory ppSig ppCache ppRule ppPrf thy = vsep $     [ kwTheoryHeader $ L.get thyName thy     , lineComment_ "Function signature and definition of the equational theory E"     , ppSig $ L.get thySignature thy-    , ppCache $ L.get thyCache thy +    , ppCache $ L.get thyCache thy     ] ++     parMap rdeepseq ppItem (L.get thyItems thy) ++     [ kwEnd ]   where-    ppItem = foldTheoryItem +    ppItem = foldTheoryItem         ppRule (prettyLemma ppPrf) (\(h,c) -> prettyFormalComment h c)  -- | Pretty print the lemma name together with its attributes.@@ -723,13 +709,13 @@   where     prettyLemmaAttribute TypingLemma    = text "typing"     prettyLemmaAttribute ReuseLemma     = text "reuse"-    prettyLemmaAttribute InvariantLemma = text "invariant"+    prettyLemmaAttribute InvariantLemma = text "use_induction"  -- | Pretty print a lemma. prettyLemma :: HighlightDocument d => (p -> d) -> Lemma p -> d prettyLemma ppPrf l =-    kwLemmaModulo "E" <-> prettyLemmaName l <> colon $-$ -    (nest 2 $ +    kwLemmaModulo "E" <-> prettyLemmaName l <> colon $-$+    (nest 2 $       sep [ prettyTraceQuantifier $ L.get lTraceQuantifier l           , doubleQuotes $ prettyFormulaE $ L.get lFormulaE l           ]@@ -750,20 +736,20 @@               ( text "proof based on the following equivalent lemma modulo AC:" $-$                 doubleQuotes (prettyFormulaAC fmAC) ) -    ppFormulaACGuarded fmAC = case fromFormulaNegate fmAC of-        Left err -> multiComment_ +    ppFormulaACGuarded fmAC = case formulaToGuarded fmAC of+        Left err -> multiComment_             ["conversion to doubly-guarded formula failed:", err]-        Right gf -> case toSequentTraceQuantifier $ L.get lTraceQuantifier l of+        Right gf -> case toSystemTraceQuantifier $ L.get lTraceQuantifier l of           ExistsNoTrace -> multiComment             ( text "guarded formula characterizing all counter-examples:" $-$-              doubleQuotes (prettyGuarded gf) )+              doubleQuotes (prettyGuarded (gnot gf)) )           ExistsSomeTrace -> multiComment             ( text "guarded formula characterizing all satisfying traces:" $-$-              doubleQuotes (prettyGuarded (negateGuarded gf)) )+              doubleQuotes (prettyGuarded gf) )      {-     ppFormulaACInduction fmAC = case fmInd of-        Left err -> multiComment_ +        Left err -> multiComment_             ["formula cannot be proven by induction:", err]         Right gf -> multiComment             ( text "proof by induction possible over the formula:" $-$@@ -779,7 +765,7 @@ {- -- | Pretty-print the intruder variants section. prettyIntrVariantsSection :: HighlightDocument d => [IntrRuleAC] -> d-prettyIntrVariantsSection rules = +prettyIntrVariantsSection rules =     prettyFormalComment "section" " Finite Variants of the Intruder Rules " $--$     nest 1 (prettyIntruderVariants rules) -}@@ -792,7 +778,7 @@ prettyIncrementalProof = prettyProofWith ppStep (const id)   where     ppStep step =-       (if isNothing (psInfo step) then text "!" else emptyDoc) <-> +       (if isNothing (psInfo step) then text "!" else emptyDoc) <->        prettyProofMethod (psMethod step)  -- | Pretty print an closed rule together with its assertion soundness proof.@@ -809,25 +795,26 @@  -- | Pretty print an open theory. prettyOpenTheory :: HighlightDocument d => OpenTheory -> d-prettyOpenTheory = +prettyOpenTheory =     prettyTheory prettySignaturePure                  (const emptyDoc) prettyOpenProtoRule prettyProof                  -- prettyIntrVariantsSection prettyOpenProtoRule prettyProof  -- | Pretty print a closed theory. prettyClosedTheory :: HighlightDocument d => ClosedTheory -> d-prettyClosedTheory thy = +prettyClosedTheory thy =     prettyTheory prettySignatureWithMaude-                 (const emptyDoc)-                 -- (prettyIntrVariantsSection . intruderRules . L.get crcRules) +                 ppUniqueFactInsts+                 -- (prettyIntrVariantsSection . intruderRules . L.get crcRules)                  prettyClosedProtoRule                  prettyIncrementalProof                  thy-    -- $--$-    -- (multiComment $ -      -- let ruEs = getProtoRuleEs thy-      -- in prettyAbstractState ruEs $ absInterpretation ruEs-    -- )+  where+    ppUniqueFactInsts crc = case S.toList $ L.get crcUniqueFactInsts crc of+      []   -> emptyDoc+      tags -> lineComment $ sep+                [ text "looping facts with unique instances:"+                , nest 2 $ fsepList (text . showFactTagArity) tags ]  prettyClosedSummary :: Document d => ClosedTheory -> d prettyClosedSummary thy =@@ -836,9 +823,9 @@     lemmaSummaries = do         LemmaItem lem  <- L.get thyItems thy         let (status, Sum siz) = foldProof proofStepSummary $ L.get lProof lem-            quantifier = (toSequentTraceQuantifier $ L.get lTraceQuantifier lem)+            quantifier = (toSystemTraceQuantifier $ L.get lTraceQuantifier lem)             analysisType = parens $ prettyTraceQuantifier $ L.get lTraceQuantifier lem-        return $ text (L.get lName lem) <-> analysisType <> colon <-> +        return $ text (L.get lName lem) <-> analysisType <> colon <->                  text (showProofStatus quantifier status) <->                  parens (integer siz <-> text "steps")
− src/Theory/AbstractInterpretation.hs 
@@ -1,136 +0,0 @@-{-# LANGUAGE BangPatterns, ViewPatterns #-}--- |--- Copyright   : (c) 2012 Benedikt Schmidt & Simon Meier--- License     : GPL v3 (see LICENSE)--- --- Maintainer  : Simon Meier <iridcode@gmail.com>------ Abstract intepretation for partial evaluation of multiset rewriting--- systems.-module Theory.AbstractInterpretation (-  -- * Combinator to define abstract interpretations-    interpretAbstractly--  -- ** Actual interpretations-  , EvaluationStyle(..)-  , partialEvaluation--  ) where--import           Debug.Trace--import           Control.Basics-import           Control.Monad.Bind-import           Control.Monad.Reader--import           Data.List-import qualified Data.Set as S-import           Data.Traversable (traverse)-import           Data.Label--import           Text.PrettyPrint.Highlight-import           Term.Substitution-import           Theory.Rule----------------------------------------------------------------------------------- Abstract enough versions of builtin rules for computing------------------------------------------------------------------------------------ | Higher-order combinator to construct abstract interpreters.-interpretAbstractly-    :: (Eq s, HasFrees i, Apply i)-    => ([Equal LNFact] -> [LNSubstVFresh]) -    -- ^ Unification  of equalities over facts. We assume that facts with-    -- different tags are never unified.-    -> s                  -- ^ Initial abstract state.-    -> (LNFact -> s -> s) -- ^ Add a fact to the abstract state-    -> (s -> [LNFact])    -- ^ Facts of a state.-    -> [Rule i]-    -- ^ Multiset rewriting rules to apply abstractly.-    -> [(s, [Rule i])]-    -- ^ Sequence of abstract states and refined versions of all given-    -- multiset rewriting rules.-interpretAbstractly unifyFactEqs initState addFact stateFacts rus =-    go st0-  where-    st0 = addFact (freshFact (varTerm (LVar "z" LSortFresh 0))) $-          addFact (inFact (varTerm (LVar "z" LSortMsg   0))) $-          initState--    -- Repeatedly refine all rules and add all their conclusions until the-    -- state doesn't change anymore.-    go st =-        (st, rus') : if st == st' then [] else go st'-      where-        rus' = concatMap refineRule rus-        st'  = foldl' (flip addFact) st $ concatMap (get rConcs) rus'--        -- Refine a rule in the context of an abstract state: for all premise-        -- to state facts combinations, try to solve the corresponding-        -- E-unification problem. If successful, return the rule with the-        -- unifier applied.-        refineRule ru = (`evalFreshT` avoid ru) $ do-            eqs <- forM (get rPrems ru) $ \prem -> msum $ do -                fa <- stateFacts st-                guard (factTag prem == factTag fa)-                -- we compute a list of 'FreshT []' actions for the outer msum-                return (Equal prem <$> rename fa)-            subst <- msum $ freshToFree <$> unifyFactEqs eqs-            return $ apply subst ru---- | How to report on performing a partial evaluation.-data EvaluationStyle = Silent | Summary | Tracing---- | Concrete partial evaluator activated with flag: --partial-evaluation-partialEvaluation :: EvaluationStyle -                  -> [ProtoRuleE] -> WithMaude (S.Set LNFact, [ProtoRuleE])-partialEvaluation evalStyle ruEs = reader $ \hnd ->-    consumeEvaluation $ interpretAbstractly -        ((`runReader` hnd) . unifyLNFactEqs)  -- FIXME: Use E-unification here-        S.empty-        (S.insert . absFact)-        S.toList-        ruEs-  where-    consumeEvaluation [] = error "partialEvaluation: impossible"-    consumeEvaluation ((st0, rus0) : rest0) =-        go (0 :: Int) st0 rus0 rest0-      where-        go _ st rus [] = -          ( st-          , nubBy eqModuloFreshnessNoAC $                 -- remove duplicates-            map ((`evalFresh` nothingUsed) . rename) rus-          )-        go i st _   ((st', rus') : rest) =-            withTrace (go (i + 1) st' rus' rest)-          where-            incDesc = " partial evaluation: step " ++ show i ++ " added " ++-                      show (S.size st' - S.size st) ++ " facts"-            withTrace = case evalStyle of-              Silent  -> id-              Summary -> trace incDesc-              Tracing -> trace $ incDesc ++ "\n\n" ++-                ( render $ nest 2 $ numbered' $ map prettyLNFact $-                  S.toList $ st' `S.difference` st ) ++ "\n"-                --    -- NOTE: We should use an abstract state that identifies all variables at-    -- the same position provided they have the same sort.-    absFact :: LNFact -> LNFact-    absFact fa = case fa of -        Fact OutFact _ -> outFact (varTerm (LVar "z" LSortMsg 0))-        Fact tag ts    -> Fact tag $ evalAbstraction $ traverse absTerm ts-      where-        evalAbstraction = (`evalBind` noBindings) . (`evalFreshT` nothingUsed)--        absTerm t = case viewTerm t of -          Lit (Con _)                   -> pure t-          FApp (sym@(NonAC (_f,_k))) ts  -                                        -> fApp sym <$> traverse absTerm ts-          -- | "p" `isPrefixOf` f        -> FApp sym <$> traverse absTerm ts-          _                             -> importBinding mkVar t (varName t)-          where-            mkVar name idx        = varTerm (LVar name (sortOfLNTerm t) idx)-            varName (viewTerm -> Lit (Var v)) = lvarName v-            varName _                         = "z"
− src/Theory/Atom.hs 
@@ -1,171 +0,0 @@-{-# LANGUAGE StandaloneDeriving-           , FlexibleContexts-           , TypeSynonymInstances-           , FlexibleInstances-           , DeriveDataTypeable-           , TupleSections-           , TemplateHaskell-           , ViewPatterns-  #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}-{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}-  -- spurious warnings for view patterns--- |--- Copyright   : (c) 2011, 2012 Benedikt Schmidt & Simon Meier--- License     : GPL v3 (see LICENSE)--- --- Maintainer  : Simon Meier <iridcode@gmail.com>--- Portability : GHC only------ Formulas that represent security properties.-module Theory.Atom(--  -- * Atoms-    Atom(..)-  , NAtom-  , LNAtom--  -- * LFormula-  , BLVar-  , BLAtom--  -- * Pretty-Printing-  , prettyNAtom-  )-where---- import Term.Rewriting.NormAC-import Theory.Rule-import Theory.Pretty--import Data.Monoid   (mappend)-import Data.Foldable (Foldable, foldMap)-import Data.Traversable -import Data.Generics-import Data.DeriveTH-import Data.Binary--import Control.Basics-import Control.DeepSeq----------------------------------------------------------------------------------- Atoms----------------------------------------------------------------------------------- | @Atom@'s are the atoms of trace formulas parametrized over arbitrary--- terms. -data Atom t = Action   t (Fact t)-            | EqE  t t-            | Less t t-            | Last t-            | DedBefore t t-            | EdgeA (t, ConcIdx) (t, PremIdx)-            deriving( Eq, Ord, Show, Data, Typeable )---- | @LAtom@ are the atoms we actually use in graph formulas input by the user.-type NAtom v = Atom (VTerm Name v)---- | @LAtom@ are the atoms we actually use in graph formulas input by the user.-type LNAtom = Atom LNTerm---- | 'LVar's combined with quantified variables. They occur only in 'LFormula's.-type BLVar = BVar LVar---- | Terms built over names and 'LVar's combined with quantified variables.-type BLTerm = NTerm BLVar---- | Atoms built over 'BLTerm's.-type BLAtom = Atom BLTerm----- Instances---------------instance Functor Atom where-    fmap f (Action   i fa) = Action    (f i) (fmap f fa)-    fmap f (EqE l r)       = EqE       (f l) (f r)-    fmap f (Less v u)      = Less      (f v) (f u)-    fmap f (Last i)        = Last      (f i)-    fmap f (DedBefore t i) = DedBefore (f t) (f i)-    fmap f (EdgeA x y)     = EdgeA     (first f x) (first f y)--instance Foldable Atom where-    foldMap f (Action i fa)   = -        f i `mappend` (foldMap f fa)-    foldMap f (EqE l r)       = f l `mappend` f r-    foldMap f (Less i j)      = f i `mappend` f j-    foldMap f (Last i)        = f i-    foldMap f (DedBefore t i) = f t `mappend` f i-    foldMap f (EdgeA x y)     = f (fst x) `mappend` f (fst y)--instance Traversable Atom where-    traverse f (Action i fa)   = -        Action <$> f i <*> traverse f fa-    traverse f (EqE l r)       = EqE <$> f l <*> f r-    traverse f (Less v u)      = Less <$> f v <*> f u-    traverse f (Last i)        = Last <$> f i-    traverse f (DedBefore t i) = DedBefore <$> f t <*> f i-    traverse f (EdgeA (x,i) (y,j)) = -        EdgeA <$> ((,i) <$> f x) <*> ((,j) <$> f y)--instance HasFrees t => HasFrees (Atom t) where-    foldFrees f = foldMap (foldFrees f)-    mapFrees  f = traverse (mapFrees f)--instance Apply LNAtom where-    apply subst (Action i fact)   = Action (apply subst i) (apply subst fact)-    apply subst (EqE l r)         = EqE (apply subst l) (apply subst r)-    apply subst (Less i j)        = Less (apply subst i) (apply subst j)-    apply subst (Last i)          = Last (apply subst i)-    apply subst (DedBefore t i)   = DedBefore (apply subst t) (apply subst i)-    apply subst (EdgeA x y)       = -        EdgeA (first (apply subst) x) (first (apply subst) y)--instance Apply BLVar where-    apply _     x@(Bound _) = x-    apply subst x@(Free  v) = maybe x extractVar $ imageOf subst v-      where-        extractVar (viewTerm -> Lit (Var v')) = Free v'-        extractVar _t                     = -          error $ "apply (BLVar): variable '" ++ show v ++ -                  "' substituted with term '" -- ++ show _t ++ "'"--instance Apply BLTerm where-    apply subst = (`bindTerm` applyBLLit)-      where-        applyBLLit :: Lit Name BLVar -> BLTerm-        applyBLLit l@(Var (Free v)) = -            maybe (lit l) (fmapTerm (fmap Free)) (imageOf subst v)-        applyBLLit l                = lit l--instance Apply BLAtom where-    apply subst (Action i fact)   = Action (apply subst i) (apply subst fact)-    apply subst (EqE l r)         = EqE (apply subst l) (apply subst r)-    apply subst (Less i j)        = Less (apply subst i) (apply subst j)-    apply subst (Last i)          = Last (apply subst i)-    apply subst (DedBefore t i)   = DedBefore (apply subst t) (apply subst i)-    apply subst (EdgeA x y)       = -        EdgeA (first (apply subst) x) (first (apply subst) y)------------------------------------------------------------------------------------ Pretty-Printing---------------------------------------------------------------------------------prettyNAtom :: (Show v, HighlightDocument d) => NAtom v -> d-prettyNAtom (Action v fa) = -    prettyFact prettyNTerm fa <-> opAction <-> text (show v) -prettyNAtom (EqE l r) =-    sep [prettyNTerm l <-> opEqual, prettyNTerm r]-    -- sep [prettyNTerm l <-> text "≈", prettyNTerm r]-prettyNAtom (Less u v) = text (show u) <-> opLess <-> text (show v)-prettyNAtom (Last i)   = operator_ "Last" <> parens (text (show i))-prettyNAtom (DedBefore t i) = text (show t) <-> opDedBefore <-> text (show i)-prettyNAtom (EdgeA x y) = text (show x) <-> opEdge <-> text (show y)----- derived instances-----------------------$( derive makeNFData ''Atom)-$( derive makeBinary ''Atom)
+ src/Theory/Constraint/Solver.hs view
@@ -0,0 +1,78 @@+-- |+-- Copyright   : (c) 2010-2012 Benedikt Schmidt & Simon Meier+-- License     : GPL v3 (see LICENSE)+--+-- Maintainer  : Simon Meier <iridcode@gmail.com>+-- Portability : GHC only+--+-- The public interface of the constraint solver, which implements all+-- constraint reduction rules and together with a rule application heuristic.+module Theory.Constraint.Solver (++  -- * Constraint systems+    module Theory.Constraint.System++  -- * Proof contexts+  -- | The proof context captures all relevant information about the context+  -- in which we are using the constraint solver. These are things like the+  -- signature of the message theory, the multiset rewriting rules of the+  -- protocol, the available precomputed case distinctions, whether induction+  -- should be applied or not, whether typed or untyped case distinctions are+  -- used, and whether we are looking for the existence of a trace or proving+  -- the absence of any trace satisfying the constraint system.+  , ProofContext(..)+  , pcSignature+  , pcRules+  , pcCaseDists+  , pcUseInduction+  , pcCaseDistKind+  , pcTraceQuantifier++  , InductionHint(..)++  , ClassifiedRules(..)+  , joinAllRules+  , crProtocol+  , crConstruct+  , crDestruct++  -- * Constraint reduction rules++  -- ** Contradictions+  -- | All rules that reduce a constraint system to the empty set of+  -- constraint systems. The 'Contradiction' datatype stores the information+  -- about the contradiction for later display to the user.+  , Contradiction+  , contradictions++  -- ** Precomputed case distinctions+  -- | For better speed, we precompute case distinctions. This is especially+  -- important for getting rid of all chain constraints before actually+  -- starting to verify security properties.+  , CaseDistinction+  , cdGoal+  , cdCases++  , precomputeCaseDistinctions+  , refineWithTypingAsms+  , unsolvedChainConstraints++  -- * Proof methods+  -- | Proof methods are the external to the constraint solver. They allow its+  -- small step execution. This module also provides the heuristics for+  -- selecting the best proof method to apply to a constraint system.+  , module Theory.Constraint.Solver.ProofMethod++  -- ** Convenience export+  , module Logic.Connectives++  ) where++import           Logic.Connectives+import           Theory.Constraint.Solver.CaseDistinctions+import           Theory.Constraint.Solver.Contradictions+import           Theory.Constraint.Solver.ProofMethod+import           Theory.Constraint.Solver.Types+import           Theory.Constraint.System++
+ src/Theory/Constraint/Solver/CaseDistinctions.hs view
@@ -0,0 +1,322 @@+-- |+-- Copyright   : (c) 2011,2012 Simon Meier+-- License     : GPL v3 (see LICENSE)+--+-- Maintainer  : Simon Meier <iridcode@gmail.com>+-- Portability : GHC only+--+-- Big-step proofs using case distinctions on the possible sources of a fact.+module Theory.Constraint.Solver.CaseDistinctions (+  -- * Precomputed case distinctions++  -- ** Queries+    unsolvedChainConstraints++  -- ** Construction+  , precomputeCaseDistinctions+  , refineWithTypingAsms++  -- ** Application+  , solveWithCaseDistinction++  ) where++import           Prelude                                 hiding (id, (.))+import           Safe++import           Data.Foldable                           (asum)+import qualified Data.Map                                as M+import           Data.Maybe                              (isJust)+import qualified Data.Set                                as S++import           Control.Basics+import           Control.Category+import           Control.Monad.Disj+import           Control.Monad.Reader+import           Control.Monad.State                     (gets)+import           Control.Parallel.Strategies++import           Text.PrettyPrint.Highlight++import           Extension.Data.Label+import           Extension.Prelude++import           Theory.Constraint.Solver.Contradictions (contradictorySystem)+import           Theory.Constraint.Solver.Goals+import           Theory.Constraint.Solver.Reduction+import           Theory.Constraint.Solver.Simplify+import           Theory.Constraint.Solver.Types+import           Theory.Constraint.System+import           Theory.Model+++------------------------------------------------------------------------------+-- Precomputing case distinctions+------------------------------------------------------------------------------++-- | The number of remaining chain constraints of each case.+unsolvedChainConstraints :: CaseDistinction -> [Int]+unsolvedChainConstraints =+    map (length . unsolvedChains . snd) . getDisj . get cdCases+++-- Construction+---------------++-- | The initial case distinction if the given goal is required and the+-- given typing assumptions are justified.+initialCaseDistinction+    :: ProofContext+    -> [LNGuarded]  -- ^ Typing assumptions. PRE: Must be closed formulas!+    -> Goal+    -> CaseDistinction+initialCaseDistinction ctxt typAsms goal =+    CaseDistinction goal cases+  where+    polish ((name, se), _) = ([name], se)+    se0   = emptySystem UntypedCaseDist+    cases =+        fmap polish $ runReduction instantiate ctxt se0 (avoid (goal, typAsms))+    instantiate = do+        insertGoal goal False+        mapM_ insertFormula typAsms+        solveGoal goal++-- | Refine a source case distinction by applying the additional proof step.+refineCaseDistinction+    :: ProofContext+    -> Reduction (a, [String])  -- proof step with result and path extension+    -> CaseDistinction+    -> ([a], CaseDistinction)+refineCaseDistinction ctxt proofStep th =+    ( map fst $ getDisj refinement+    , set cdCases (snd <$> refinement) th )+  where+    fs         = avoid th+    refinement = do+        (names, se)   <- get cdCases th+        ((x, names'), se') <- fst <$> runReduction proofStep ctxt se fs+        return (x, (combine names names', se'))++    -- Combine names such that the coerce rule is blended out.+    combine []            ns' = ns'+    combine ("coerce":ns) ns' = combine ns ns'+    combine (n       :_)  _   = [n]++-- | Solves all chain and splitting goals as well as all premise goals solvable+-- with one of the given precomputed requires case distinction theorems, while+-- repeatedly simplifying the proof state.+--+-- Returns the names of the steps applied.+solveAllSafeGoals :: [CaseDistinction] -> Reduction [String]+solveAllSafeGoals ths =+    solve []+  where+    -- safeGoal _ _ = False+    safeGoal _       (_,   (_, Useless)) = False+    safeGoal doSplit (goal, _          ) =+      case goal of+        ChainG _ _    -> True+        ActionG _ fa  -> not (isKUFact fa)+        PremiseG _ fa -> not (isKUFact fa)+        DisjG _       -> doSplit+        -- Uncomment to get more extensive case splitting+        -- SplitG _   -> doSplit+        SplitG _      -> False++    usefulGoal (_, (_, Useful)) = True+    usefulGoal _                = False++    solve caseNames = do+        simplifySystem+        ctxt <- ask+        contradictoryIf =<< gets (contradictorySystem ctxt)+        goals  <- gets openGoals+        chains <- gets unsolvedChains+        -- try to either solve a safe goal or use one of the precomputed case+        -- distinctions+        let noChainGoals = null [ () | (ChainG _ _, _) <- goals ]+            -- we perform equation splits, if there is a chain goal starting+            -- from a message variable; i.e., a chain constraint that is no+            -- open goal.+            splitAllowed = noChainGoals && not (null chains)+            safeGoals    = fst <$> filter (safeGoal splitAllowed) goals+            usefulGoals  = fst <$> filter usefulGoal goals+            nextStep        =+                ((fmap return . solveGoal) <$> headMay safeGoals) <|>+                (asum $ map (solveWithCaseDistinction ctxt ths) usefulGoals)+        case nextStep of+          Nothing   -> return $ caseNames+          Just step -> solve . (caseNames ++) =<< step+++------------------------------------------------------------------------------+-- Applying precomputed case distinctions+------------------------------------------------------------------------------++-- | Match a precomputed 'CaseDistinction' to a goal.+matchToGoal+    :: ProofContext     -- ^ Proof context used for refining the case distinction.+    -> CaseDistinction  -- ^ Case distinction to use.+    -> Goal             -- ^ Goal to match+    -> Maybe CaseDistinction+    -- ^ An adapted version of the case distinction and a matcher of the case+    -- distinction goal to the substitution goal.+matchToGoal ctxt th goalTerm =+  case (goalTerm, get cdGoal th) of+    ( PremiseG      (iTerm, premIdxTerm) faTerm+     ,PremiseG pPat@(iPat,  _          ) faPat  ) ->+        let match = faTerm `matchFact` faPat <> iTerm `matchLVar` iPat in+        case runReader (solveMatchLNTerm match) (get pcMaudeHandle ctxt) of+            []      -> Nothing+            subst:_ ->+                let refine = do+                        modM sEdges (substNodePrem pPat (iPat, premIdxTerm))+                        void (solveSubstEqs SplitNow subst)+                        return ((), [])+                in Just $ snd $ refineCaseDistinction ctxt refine th++    (ActionG iTerm faTerm, ActionG iPat faPat) ->+        let match = faTerm `matchFact` faPat <> iTerm `matchLVar` iPat in+        case runReader (solveMatchLNTerm match) (get pcMaudeHandle ctxt) of+            []      -> Nothing+            subst:_ ->+                let refine = do+                        void (solveSubstEqs SplitNow subst)+                        return ((), [])+                in Just $ snd $ refineCaseDistinction ctxt refine th++    -- No other matches possible, as we only precompute case distinctions for+    -- premises and KU-actions.+    _ -> Nothing+  where+    substNodePrem from to = S.map+        (\ e@(Edge c p) -> if p == from then Edge c to else e)++-- | Try to solve a premise goal or 'Ded' action using the first precomputed+-- case distinction with a matching premise.+solveWithCaseDistinction :: ProofContext+                         -> [CaseDistinction]+                         -> Goal+                         -> Maybe (Reduction [String])+solveWithCaseDistinction hnd ths goal = do+    -- goal <- toBigStepGoal goal0+    asum [ applyCaseDistinction hnd th goal | th <- ths ]++-- | Apply a precomputed case distinction theorem to a required fact.+applyCaseDistinction :: ProofContext+                     -> CaseDistinction    -- ^ Case distinction theorem.+                     -> Goal               -- ^ Required goal+                     -> Maybe (Reduction [String])+applyCaseDistinction ctxt th goal+  | isJust $ matchToGoal ctxt th goal = Just $ do+        markGoalAsSolved "precomputed" goal+        thRenamed <- rename th+        let thInst = fromJustNote "applyCaseDistinction: impossible" $+                         matchToGoal ctxt thRenamed goal+        (names, sysTh) <- disjunctionOfList $ getDisj $ get cdCases thInst+        conjoinSystem sysTh+        return names++  | otherwise = Nothing++-- | Saturate the case distinctions with respect to each other such that no+-- additional splitting is introduced; i.e., only rules with a single or no+-- conclusion are used for the saturation.+saturateCaseDistinctions+    :: ProofContext -> [CaseDistinction] -> [CaseDistinction]+saturateCaseDistinctions ctxt =+    go+  where+    go ths =+        if any or (changes `using` parList rdeepseq)+          then go ths'+          else ths'+      where+        (changes, ths') = unzip $ map (refineCaseDistinction ctxt solver) ths+        goodTh th  = length (getDisj (get cdCases th)) <= 1+        solver     = do names <- solveAllSafeGoals (filter goodTh ths)+                        return (not $ null names, names)++-- | Precompute a saturated set of case distinctions.+precomputeCaseDistinctions+    :: ProofContext+    -> [LNGuarded] -- ^ Typing assumptions.+    -> [CaseDistinction]+precomputeCaseDistinctions ctxt typAsms =+    map cleanupCaseNames $ saturateCaseDistinctions ctxt rawCaseDists+  where+    cleanupCaseNames = modify cdCases $ fmap $ first $+        filter (not . null)+      . map (filter (`elem` '_' : ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9']))++    rawCaseDists =+      initialCaseDistinction ctxt typAsms <$> (protoGoals ++ msgGoals)++    -- construct case distinction starting from facts from non-special rules+    protoGoals = someProtoGoal <$> absProtoFacts+    msgGoals   = someKUGoal <$> absMsgFacts++    getProtoFact (Fact KUFact _ ) = mzero+    getProtoFact (Fact KDFact _ ) = mzero+    getProtoFact fa               = return fa++    absFact (Fact tag ts) = (tag, length ts)++    nMsgVars n = [ varTerm (LVar "t" LSortMsg i) | i <- [1..fromIntegral n] ]++    someProtoGoal :: (FactTag, Int) -> Goal+    someProtoGoal (tag, arity) =+        PremiseG (someNodeId, PremIdx 0) (Fact tag (nMsgVars arity))++    someKUGoal :: LNTerm -> Goal+    someKUGoal m =+        ActionG someNodeId (Fact KUFact [varTerm (LVar "f_" LSortMsg 0), m])++    someNodeId = LVar "i" LSortNode 0++    -- FIXME: Also use facts from proof context.+    rules = get pcRules ctxt+    absProtoFacts = sortednub $ do+        ru <- joinAllRules rules+        fa <- absFact <$> (getProtoFact =<< (get rConcs ru ++ get rPrems ru))+        -- exclude facts handled specially by the prover+        guard (not $ fst fa `elem` [OutFact, InFact, FreshFact])+        return fa++    absMsgFacts :: [LNTerm]+    absMsgFacts = asum $ sortednub $+      [ do return $ lit $ Var (LVar "t" LSortFresh 1)++      , [ fAppNonAC (s,k) $ nMsgVars k+        | (s,k) <- S.toList . allFunctionSymbols  . mhMaudeSig . get sigmMaudeHandle . get pcSignature $ ctxt+        , (s,k) `S.notMember` implicitFunSig, k > 0 ]+      ]++-- | Refine a set of case distinction by exploiting additional typing+-- assumptions.+refineWithTypingAsms+    :: [FormulaAC]        -- ^ Typing assumptions to use.+    -> ProofContext       -- ^ Proof context to use.+    -> [CaseDistinction]  -- ^ Original, untyped case distinctions.+    -> [CaseDistinction]  -- ^ Refined, typed case distinctions.+refineWithTypingAsms typAsms0 ctxt cases0 =+    fmap (modifySystems removeFormulas) $+    saturateCaseDistinctions ctxt $+    modifySystems updateSystem <$> cases0+  where+    typAsms = map (either error id . formulaToGuarded) typAsms0+    modifySystems = modify cdCases . fmap . second+    updateSystem se =+        modify sFormulas (S.union (S.fromList typAsms)) $+        set sCaseDistKind TypedCaseDist                 $ se+    removeFormulas =+        modify sGoals (M.filterWithKey isNoDisjGoal)+      . set sFormulas S.empty+      . set sSolvedFormulas S.empty++    isNoDisjGoal (DisjG _)  _ = False+    isNoDisjGoal _          _ = True+++
+ src/Theory/Constraint/Solver/Contradictions.hs view
@@ -0,0 +1,225 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE ViewPatterns    #-}+-- |+-- Copyright   : (c) 2010-2012 Benedikt Schmidt & Simon Meier+-- License     : GPL v3 (see LICENSE)+--+-- Maintainer  : Simon Meier <iridcode@gmail.com>+-- Portability : GHC only+--+-- This is the public interface for constructing and deconstructing constraint+-- systems. The interface for performing constraint solving provided by+-- "Theory.Constraint.Solver".+module Theory.Constraint.Solver.Contradictions (++  -- * Contradictory constraint systems+    Contradiction(..)+  , substCreatesNonNormalTerms+  , contradictions+  , contradictorySystem++  -- ** Pretty-printing+  , prettyContradiction++  ) where++import           Prelude                        hiding (id, (.))++import           Data.Binary+import qualified Data.DAG.Simple                as D (cyclic, reachableSet)+import           Data.DeriveTH+import qualified Data.Foldable                  as F+import           Data.List+import qualified Data.Map                       as M+import           Data.Monoid+import qualified Data.Set                       as S++import           Control.Basics+import           Control.Category+import           Control.DeepSeq+import           Control.Monad.Reader++import qualified Extension.Data.Label           as L+import           Extension.Prelude++import           Theory.Constraint.Solver.Types+import           Theory.Constraint.System+import           Theory.Model+import           Theory.Text.Pretty++import           Term.Rewriting.Norm            (maybeNotNfSubterms, nf')+++------------------------------------------------------------------------------+-- Contradictions+------------------------------------------------------------------------------++-- | Reasons why a constraint 'System' can be contradictory.+data Contradiction =+    Cyclic                         -- ^ The paths are cyclic.+  | NonNormalTerms                 -- ^ Has terms that are not in normal form.+  -- | NonLastNode                    -- ^ Has a non-silent node after the last node.+  | ForbiddenExp                   -- ^ Forbidden Exp-down rule instance+  | NonUniqueFactInstance (NodeId, NodeId, NodeId)+    -- ^ Contradicts that certain facts have unique instances.+  | IncompatibleEqs                -- ^ Incompatible equalities.+  | FormulasFalse                  -- ^ False in formulas+  | SuperfluousLearn LNTerm NodeId -- ^ A term is derived both before and after a learn+  | NodeAfterLast (NodeId, NodeId) -- ^ There is a node after the last node.+  deriving( Eq, Ord, Show )+++-- | 'True' if the constraint system is contradictory.+contradictorySystem :: ProofContext -> System -> Bool+contradictorySystem ctxt = not . null . contradictions ctxt++-- | All CR-rules reducing a constraint system to *⟂* represented as a list of+-- trivial contradictions. Note that some constraint systems are also removed+-- because they have no unifier. This is part of unification. Note also that+-- *S_{¬,@}* is handled as part of *S_∀*.+contradictions :: ProofContext -> System -> [Contradiction]+contradictions ctxt sys = F.asum+    -- CR-rule **+    [ guard (D.cyclic $ rawLessRel sys)             *> pure Cyclic+    -- CR-rule *N1*+    , guard (hasNonNormalTerms sig sys)             *> pure NonNormalTerms+    -- CR-rule *N7*+    , guard (hasForbiddenExp sys)                   *> pure ForbiddenExp+    -- CR-rules *S_≐* and *S_≈* are implemented via the equation store+    , guard (eqsIsFalse $ L.get sEqStore sys)       *> pure IncompatibleEqs+    -- CR-rules *S_⟂*, *S_{¬,last,1}*, *S_{¬,≐}*, *S_{¬,≈}*+    , guard (S.member gfalse $ L.get sFormulas sys) *> pure FormulasFalse+    ]+    +++    -- This rule is not yet documented. It removes constraint systems that+    -- require a unique fact to be present in the system state more than once.+    -- Unique facts are declared as part of the specification of the rule+    -- system.+    (NonUniqueFactInstance <$> nonUniqueFactInstances ctxt sys)+    +++    -- TODO: Document corresponding constratint reduction rule.+    (NodeAfterLast <$> nodesAfterLast sys)+  where+    sig = L.get pcSignature ctxt++-- | True iff there are terms in the node constraints that are not in normal form wrt.+-- to 'Term.Rewriting.Norm.norm' (DH/AC).+hasNonNormalTerms :: SignatureWithMaude -> System -> Bool+hasNonNormalTerms sig se =+    any (not . (`runReader` hnd) . nf') (maybeNonNormalTerms hnd se)+  where hnd = L.get sigmMaudeHandle sig++-- | Returns all (sub)terms of node constraints that may be not in normal form.+maybeNonNormalTerms :: MaudeHandle -> System -> [LNTerm]+maybeNonNormalTerms hnd se =+    sortednub . concatMap getTerms . M.elems . L.get sNodes $ se+  where getTerms (Rule _ ps cs as) = do+          f <- ps++cs++as+          t <- factTerms f+          maybeNotNfSubterms (mhMaudeSig hnd) t++substCreatesNonNormalTerms :: MaudeHandle -> System -> LNSubstVFresh -> Bool+substCreatesNonNormalTerms hnd se =+    \subst -> any (not . nfApply subst) terms+  where terms = maybeNonNormalTerms hnd se+        nfApply subst0 t = t == t'  || nf' t' `runReader` hnd+          where tvars = freesList t+                subst = restrictVFresh tvars subst0+                t'  = apply (freshToFreeAvoidingFast subst tvars) t++-- | True if there is no @EXP-down@ rule that should be replaced by an+-- @EXP-up@ rule.+hasForbiddenExp :: System -> Bool+hasForbiddenExp se =+    any (isForbiddenExp) $ M.elems $ L.get sNodes se++-- | @isForbiddenExp ru@ returns @True@ if @ru@ is not allowed in+-- a normal dependency graph.+-- > isForbiddenExp (Rule () [undefined, Fact KUFact [undefined, Mult (Inv x1) x2]]+--                           [Fact KDFact [expTagToTerm IsExp, Exp p1 (Mult x2 x3)]] [])+-- > False+-- > isForbiddenExp (Rule () [undefined, Fact KUFact [undefined, Mult (Inv x1) x2]]+--                           [Fact KDFact [expTagToTerm IsExp, Exp p1 x2]] [])+-- > True+isForbiddenExp :: Rule a -> Bool+isForbiddenExp ru = maybe False id $ do+    [_,p2] <- return $ L.get rPrems ru+    [conc] <- return $ L.get rConcs ru+    (UpK, _,          b) <- kFactView p2+    (DnK, Just CannotExp, viewTerm2 -> FExp g c) <- kFactView conc++    -- g should be public and the required inputs for c already required by b+    guard (sortOfLNTerm g == LSortPub && (inputTerms c \\ inputTerms b == []))+    return True+    -- FIXME: change according to:  guard p >> return True  =  return p+++-- | Compute all contradictions to unique fact instances.+--+-- Constraint systems are contradictory, where 'f' is a fact symbol+-- with unique instances and temporal variables i, j, and k are ordered+-- according to i < j < k, j requires a premise f(t), and i provides a+-- conclusion f(t) for the node k. Graphically, the edge from i to k is+-- interrupted by the node j that requires the same fact carried on the edge.+nonUniqueFactInstances :: ProofContext -> System+                       -> [(NodeId, NodeId, NodeId)]+nonUniqueFactInstances ctxt se = do+    Edge c@(i, _) (k, _) <- S.toList $ L.get sEdges se+    let tag = factTag (nodeConcFact c se)+    guard (tag `S.member` L.get pcUniqueFactInsts ctxt)+    j <- S.toList $ D.reachableSet [i] less++    let isCounterExample = (j /= i) && (j /= k) &&+                           maybe False checkRule (M.lookup j $ L.get sNodes se)++        checkRule jRu    = any ((tag ==) . factTag) (L.get rPrems jRu) &&+                           k `S.member` D.reachableSet [j] less++    guard isCounterExample+    return (i, j, k) -- counter-example to unique fact instances+  where+    less = rawLessRel se++-- | The node-ids that must be instantiated to the trace, but are temporally+-- after the last node.+nodesAfterLast :: System -> [(NodeId, NodeId)]+nodesAfterLast sys = case L.get sLastAtom sys of+  Nothing -> []+  Just i  -> do j <- S.toList $ D.reachableSet [i] $ rawLessRel sys+                guard (j /= i && isInTrace sys j)+                return (i, j)+++-- | Pretty-print a 'Contradiction'.+prettyContradiction :: Document d => Contradiction -> d+prettyContradiction contra = case contra of+    Cyclic                    -> text "cyclic"+    IncompatibleEqs           -> text "incompatible equalities"+    NonNormalTerms            -> text "non-normal terms"+    ForbiddenExp              -> text "non-normal exponentiation instance"+    NonUniqueFactInstance cex -> text $ "non-unique facts " ++ show cex+    FormulasFalse             -> text "from formulas"+    SuperfluousLearn m v      ->+        doubleQuotes (prettyLNTerm m) <->+        text ("derived before and after") <->+        doubleQuotes (prettyNodeId v)+    NodeAfterLast (i,j)       ->+        text $ "node " ++ show j ++ " after last node " ++ show i+++-- Instances+------------++instance HasFrees Contradiction where+  foldFrees f (SuperfluousLearn t v)    = foldFrees f t `mappend` foldFrees f v+  foldFrees f (NonUniqueFactInstance x) = foldFrees f x+  foldFrees f (NodeAfterLast x)         = foldFrees f x+  foldFrees _ _                         = mempty++  mapFrees f (SuperfluousLearn t v)    = SuperfluousLearn <$> mapFrees f t <*> mapFrees f v+  mapFrees f (NonUniqueFactInstance x) = NonUniqueFactInstance <$> mapFrees f x+  mapFrees f (NodeAfterLast x)         = NodeAfterLast <$> mapFrees f x+  mapFrees _ c                         = pure c++$( derive makeBinary ''Contradiction)+$( derive makeNFData ''Contradiction)
+ src/Theory/Constraint/Solver/Goals.hs view
@@ -0,0 +1,244 @@+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE ViewPatterns  #-}+-- |+-- Copyright   : (c) 2010-2012 Benedikt Schmidt & Simon Meier+-- License     : GPL v3 (see LICENSE)+--+-- Maintainer  : Simon Meier <iridcode@gmail.com>+-- Portability : GHC only+--+-- The constraint reduction rules, which are not enforced as invariants in+-- "Theory.Constraint.Solver.Reduction".+--+-- A goal represents a possible application of a rule that may result in+-- multiple cases or even non-termination (if applied repeatedly). These goals+-- are computed as the list of 'openGoals'. See+-- "Theory.Constraint.Solver.ProofMethod" for the public interface to solving+-- goals and the implementation of heuristics.+module Theory.Constraint.Solver.Goals (+    Usefulness(..)+  , AnnotatedGoal+  , openGoals+  , solveGoal+  ) where++import           Prelude                                 hiding (id, (.))++import qualified Data.DAG.Simple                         as D (cyclic)+import qualified Data.Map                                as M++import           Control.Basics+import           Control.Category+import           Control.Monad.Disj+import           Control.Monad.State                     (gets)++import           Extension.Data.Label++import           Theory.Constraint.Solver.Contradictions (substCreatesNonNormalTerms)+import           Theory.Constraint.Solver.Reduction+import           Theory.Constraint.Solver.Types+import           Theory.Constraint.System+import           Theory.Model+++------------------------------------------------------------------------------+-- Extracting Goals+------------------------------------------------------------------------------++data Usefulness = Useful | Useless+  deriving (Show, Eq, Ord)++-- | Goals annotated with their number and usefulness.+type AnnotatedGoal = (Goal, (Integer, Usefulness))+++-- | The list of goals that must be solved before a solution can be extracted.+-- Each goal is annotated with its age and an indicator for its usefulness.+openGoals :: System -> [AnnotatedGoal]+openGoals sys = do+    (goal, status) <- M.toList $ get sGoals sys+    let solved = get gsSolved status+    -- check whether the goal is still open+    guard $ case goal of+        ActionG _ (kFactView -> Just (UpK, _, m)) ->+          not $    solved+                || isMsgVar m || sortOfLNTerm m == LSortPub+                -- handled by 'insertAction'+                || isPair m || isInverse m || isProduct m+        ActionG _ _                               -> not solved+        PremiseG _ _                              -> not solved+        -- Technically the 'False' disj would be a solvable goal. However, we+        -- have a separate proof method for this, i.e., contradictions.+        DisjG (Disj [])                           -> False+        DisjG _                                   -> not solved++        ChainG c _     ->+          case kFactView (nodeConcFact c sys) of+              Just (DnK, _, m) | isMsgVar m -> False+                               | otherwise  -> not solved+              fa -> error $ "openChainGoals: impossible fact: " ++ show fa++        -- FIXME: Split goals may be duplicated, we always have to check+        -- explicitly if they still exist.+        SplitG idx -> splitExists (get sEqStore sys) idx++    let useful = case goal of+          -- Note that 'solveAllSafeGoals' in "CaseDistinctions" relies on+          -- looping goals being classified as 'Useless'.+          _ | get gsLoopBreaker status              -> Useless+          ActionG i (kFactView -> Just (UpK, _, m))+            | isSimpleTerm m || deducible i m       -> Useless+          _                                         -> Useful++    return (goal, (get gsNr status, useful))+  where+    existingDeps = rawLessRel sys++    -- We use the following heuristic for marking KU-actions as useful (worth+    -- solving now) or useless (to be delayed until no more useful goals+    -- remain). We ignore all goals that are simple terms or where there+    -- exists a node, not after the premise or the last node, providing an Out+    -- or KD conclusion that provides the message we are looking for as a+    -- toplevel term. If such a node exist, then solving the goal will result+    -- in at least one case where we didn't make real progress except.+    toplevelTerms t@(destPair -> Just (t1, t2)) =+        t : toplevelTerms t1 ++ toplevelTerms t2+    toplevelTerms t@(destInverse -> Just t1) = t : toplevelTerms t1+    toplevelTerms t = [t]++    deducible i m = or $ do+        (j, ru) <- M.toList $ get sNodes sys+        -- We cannot deduce a message from a last node.+        guard (not $ isLast sys j)+        let derivedMsgs = concatMap toplevelTerms $+                [ t | Fact OutFact [t] <- get rConcs ru] <|>+                [ t | Just (DnK, _, t) <- kFactView <$> get rConcs ru]+        -- m is deducible from j without an immediate contradiction+        -- if it is a derived message of 'ru' and the dependency does+        -- not make the graph cyclic.+        return $ m `elem` derivedMsgs &&+                 not (D.cyclic ((j, i) : existingDeps))+++------------------------------------------------------------------------------+-- Solving 'Goal's+------------------------------------------------------------------------------++-- | @solveGoal rules goal@ enumerates all possible cases of how this goal+-- could be solved in the context of the given @rules@. For each case, a+-- sensible case-name is returned.+solveGoal :: Goal -> Reduction String+solveGoal goal = do+    -- mark before solving, as representation might change due to unification+    markGoalAsSolved "directly" goal+    rules <- askM pcRules+    case goal of+      ActionG i fa  -> solveAction  (nonSilentRules rules) (i, fa)+      PremiseG p fa ->+           solvePremise (get crProtocol rules ++ get crConstruct rules) p fa+      ChainG c p    -> solveChain (get crDestruct  rules) (c, p)+      SplitG i      -> solveSplit i+      DisjG disj    -> solveDisjunction disj++-- The follwoing functions are internal to 'solveGoal'. Use them with great+-- care.++-- | CR-rule *S_at*: solve an action goal.+solveAction :: [RuleAC]          -- ^ All rules labelled with an action+            -> (NodeId, LNFact)  -- ^ The action we are looking for.+            -> Reduction String  -- ^ A sensible case name.+solveAction rules (i, fa) = do+    mayRu <- M.lookup i <$> getM sNodes+    showRuleCaseName <$> case mayRu of+        Nothing -> do ru  <- labelNodeId i rules+                      act <- disjunctionOfList $ get rActs ru+                      void (solveFactEqs SplitNow [Equal fa act])+                      return ru++        Just ru -> do unless (fa `elem` get rActs ru) $ do+                          act <- disjunctionOfList $ get rActs ru+                          void (solveFactEqs SplitNow [Equal fa act])+                      return ru++-- | CR-rules *DG_{2,P}* and *DG_{2,d}*: solve a premise with a direct edge+-- from a unifying conclusion or using a destruction chain.+--+-- Note that *In*, *Fr*, and *KU* facts are solved directly when adding a+-- 'ruleNode'.+--+solvePremise :: [RuleAC]       -- ^ All rules with a non-K-fact conclusion.+             -> NodePrem       -- ^ Premise to solve.+             -> LNFact         -- ^ Fact required at this premise.+             -> Reduction String -- ^ Case name to use.+solvePremise rules p faPrem+  | isKDFact faPrem = do+      iLearn    <- freshLVar "vl" LSortNode+      mLearn    <- varTerm <$> freshLVar "t" LSortMsg+      concLearn <- kdFact (Just CanExp) mLearn+      let premLearn = outFact mLearn+          -- !! Make sure that you construct the correct rule!+          ruLearn = Rule (IntrInfo IRecvRule) [premLearn] [concLearn] []+          cLearn = (iLearn, ConcIdx 0)+          pLearn = (iLearn, PremIdx 0)+      modM sNodes  (M.insert iLearn ruLearn)+      insertChain cLearn p+      solvePremise rules pLearn premLearn++  | otherwise = do+      (ru, c, faConc) <- insertFreshNodeConc rules+      insertEdges [(c, faConc, faPrem, p)]+      return $ showRuleCaseName ru++-- | CR-rule *DG2_chain*: solve a chain constraint.+solveChain :: [RuleAC]              -- ^ All destruction rules.+           -> (NodeConc, NodePrem)  -- ^ The chain to extend by one step.+           -> Reduction String      -- ^ Case name to use.+solveChain rules (c, p) = do+    faConc  <- gets $ nodeConcFact c+    (do -- solve it by a direct edge+        faPrem <- gets $ nodePremFact p+        insertEdges [(c, faConc, faPrem, p)]+        let m = case kFactView faConc of+                  Just (DnK, _, m') -> m'+                  _                 -> error $ "solveChain: impossible"+            caseName (viewTerm -> FApp o _) = show o+            caseName t                      = show t+        return $ caseName m+     `disjunction`+     do -- extend it with one step+        (i, ru)     <- insertFreshNode rules+        (v, faPrem) <- disjunctionOfList $ enumPrems ru+        insertEdges [(c, faConc, faPrem, (i, v))]+        markGoalAsSolved "directly" (PremiseG (i, v) faPrem)+        insertChain (i, ConcIdx 0) p+        return $ showRuleCaseName ru+     )++-- | Solve an equation split. There is no corresponding CR-rule in the rule+-- system on paper because there we eagerly split over all variants of a rule.+-- In practice, this es too expensive and we therefore use the equation store+-- to delay these splits.+solveSplit :: SplitId -> Reduction String+solveSplit x = do+    split <- gets ((`performSplit` x) . get sEqStore)+    let errMsg = error "solveSplit: inexistent split-id"+    store      <- maybe errMsg disjunctionOfList split+    -- FIXME: Simplify this interaction with the equation store+    hnd        <- getMaudeHandle+    substCheck <- gets (substCreatesNonNormalTerms hnd)+    store'     <- simp hnd substCheck store+    contradictoryIf (eqsIsFalse store')+    sEqStore =: store'+    return "split"++-- | CR-rule *S_disj*: solve a disjunction of guarded formulas using a case+-- distinction.+--+-- In contrast to the paper, we use n-ary disjunctions and also split over all+-- of them at once.+solveDisjunction :: Disj LNGuarded -> Reduction String+solveDisjunction disj = do+    (i, gfm) <- disjunctionOfList $ zip [(1::Int)..] $ getDisj disj+    insertFormula gfm+    return $ "case_" ++ show i+
+ src/Theory/Constraint/Solver/ProofMethod.hs view
@@ -0,0 +1,403 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections   #-}+{-# LANGUAGE ViewPatterns    #-}+-- |+-- Copyright   : (c) 2010-2012 Simon Meier & Benedikt Schmidt+-- License     : GPL v3 (see LICENSE)+--+-- Maintainer  : Simon Meier <iridcode@gmail.com>+-- Portability : GHC only+--+-- Proof methods and heuristics: the external small-step interface to the+-- constraint solver.+module Theory.Constraint.Solver.ProofMethod (+  -- * Proof methods+    CaseName+  , ProofMethod(..)+  , execProofMethod++  -- ** Heuristics+  , GoalRanking(..)+  , goalRankingName+  , rankProofMethods++  , Heuristic+  , roundRobinHeuristic+  , useHeuristic++  -- ** Pretty Printing+  , prettyProofMethod++) where++import           Data.Binary+import           Data.DeriveTH+import           Data.Function                             (on)+import           Data.Label                                hiding (get)+import qualified Data.Label                                as L+import           Data.List+import qualified Data.Map                                  as M+import           Data.Monoid+import           Data.Ord                                  (comparing)+import qualified Data.Set                                  as S+import           Extension.Prelude                         (sortOn)++import           Control.Basics+import           Control.DeepSeq+import           Control.Monad.Bind+import qualified Control.Monad.Trans.PreciseFresh          as Precise++import           Theory.Constraint.Solver.CaseDistinctions+import           Theory.Constraint.Solver.Contradictions+import           Theory.Constraint.Solver.Goals+import           Theory.Constraint.Solver.Reduction+import           Theory.Constraint.Solver.Simplify+import           Theory.Constraint.Solver.Types+import           Theory.Constraint.System+import           Theory.Model+import           Theory.Text.Pretty+++------------------------------------------------------------------------------+-- Utilities+------------------------------------------------------------------------------++-- | @uniqueListBy eq changes xs@ zips the @changes@ with all sequences equal+-- elements in the list.+--+-- > uniqueListBy compare id (const [ (++ show i) | i <- [1..] ]) ["a","b","a"] =+-- > ["a1","b","a2"]+--+uniqueListBy :: (a -> a -> Ordering) -> (a -> a) -> (Int -> [a -> a]) -> [a] -> [a]+uniqueListBy ord single distinguish xs0 =+      map fst+    $ sortBy (comparing snd)+    $ concat $ map uniquify $ groupBy (\x y -> ord (fst x) (fst y) == EQ)+    $ sortBy (ord `on` fst)+    $ zip xs0 [(0::Int)..]+  where+    uniquify []      = error "impossible"+    uniquify [(x,i)] = [(single x, i)]+    uniquify xs      = zipWith (\f (x,i) -> (f x, i)) dist xs+      where+        dist = distinguish $ length xs+++------------------------------------------------------------------------------+-- Proof Methods+------------------------------------------------------------------------------++-- | Every case in a proof is uniquely named.+type CaseName = String++-- | Sound transformations of sequents.+data ProofMethod =+    Sorry String                         -- ^ Proof was not completed+  | Solved                               -- ^ An attack was fond+  | Simplify                             -- ^ A simplification step.+  | SolveGoal Goal                       -- ^ A goal that was solved.+  | Contradiction (Maybe Contradiction)  -- ^ A contradiction could be+                                         -- derived, possibly with a reason.+  | Induction                            -- ^ Use inductive strengthening on+                                         -- the single formula constraint in+                                         -- the system.+  deriving( Eq, Ord, Show )++instance HasFrees ProofMethod where+    foldFrees f (SolveGoal g)     = foldFrees f g+    foldFrees f (Contradiction c) = foldFrees f c+    foldFrees _ _                 = mempty++    mapFrees f (SolveGoal g)     = SolveGoal <$> mapFrees f g+    mapFrees f (Contradiction c) = Contradiction <$> mapFrees f c+    mapFrees _ method            = pure method+++-- Proof method execution+-------------------------+++-- @execMethod rules method se@ checks first if the @method@ is applicable to+-- the sequent @se@. Then, it applies the @method@ to the sequent under the+-- assumption that the @rules@ describe all rewriting rules in scope.+--+-- NOTE that the returned systems have their free substitution fully applied+-- and all variable indices reset.+execProofMethod :: ProofContext+                -> ProofMethod -> System -> Maybe (M.Map CaseName System)+execProofMethod ctxt method sys =+    M.map cleanupSystem <$>+      case method of+        Sorry _                  -> return M.empty+        Solved+          | null (openGoals sys) -> return M.empty+          | otherwise            -> Nothing+        SolveGoal goal           -> execSolveGoal goal+        Simplify                 -> singleCase (/=) simplifySystem+        Induction                -> execInduction+        Contradiction _+          | null (contradictions ctxt sys) -> Nothing+          | otherwise                      -> Just M.empty+  where+    -- at this point it is safe to remove the free substitution, as all+    -- systems have it fully applied (by the virtue of a call to+    -- simplifySystem). We also reset the variable indices here.+    cleanupSystem =+         (`Precise.evalFresh` Precise.nothingUsed)+       . (`evalBindT` noBindings)+       . someInst+       . set sSubst emptySubst+++    -- expect only one or no subcase in the given case distinction+    singleCase check m =+        case map fst $ getDisj $ execReduction m ctxt sys (avoid sys) of+          []                      -> return $ M.empty+          [sys'] | check sys sys' -> return $ M.singleton "" sys'+                 | otherwise      -> mzero+          syss                    ->+               return $ M.fromList (zip (map show [(1::Int)..]) syss)++    -- solve the given goal+    -- PRE: Goal must be valid in this system.+    execSolveGoal goal = do+        return $ makeCaseNames $ map fst $ getDisj $+            runReduction solver ctxt sys (avoid sys)+      where+        ths    = L.get pcCaseDists ctxt+        solver = do name <- maybe (solveGoal goal)+                                  (fmap $ concat . intersperse "_")+                                  (solveWithCaseDistinction ctxt ths goal)+                    simplifySystem+                    return name++        makeCaseNames =+            M.fromListWith (error "case names not unique")+          . uniqueListBy (comparing fst) id distinguish+          where+            distinguish n =+                [ (\(x,y) -> (x ++ "_case_" ++ pad (show i), y))+                | i <- [(1::Int)..] ]+              where+                l      = length (show n)+                pad cs = replicate (l - length cs) '0' ++ cs++    -- Apply induction: possible if the system contains only+    -- a single formula.+    execInduction+      | sys == sys0 =+          case S.toList $ L.get sFormulas sys of+            [gf] -> case ginduct gf of+              Right gf' -> Just $ M.singleton "induction"+                                $ set sFormulas (S.singleton gf') sys+              _         -> Nothing+            _    -> Nothing++      | otherwise = Nothing+      where+        sys0 = set sFormulas (L.get sFormulas sys)+             $ set sLemmas (L.get sLemmas sys)+             $ emptySystem (L.get sCaseDistKind sys)+++------------------------------------------------------------------------------+-- Heuristics+------------------------------------------------------------------------------++-- | The different available functions to rank goals with respect to their+-- order of solving in a constraint system.+data GoalRanking =+    GoalNrRanking+  | UsefulGoalNrRanking+  | SmartRanking Bool+  deriving( Eq, Ord, Show )++-- | The name/explanation of a 'GoalRanking'.+goalRankingName :: GoalRanking -> String+goalRankingName ranking =+    "Goals sorted according to " ++ case ranking of+        GoalNrRanking                -> "their order of creation"+        UsefulGoalNrRanking          -> "their usefulness and order of creation"+        SmartRanking useLoopBreakers -> smart useLoopBreakers+   where+     smart b = "the 'smart' heuristic (loop breakers " +++               (if b then "allowed" else "delayed") ++ ")."++-- | Use a 'GoalRanking' to sort a list of 'AnnotatedGoal's stemming from the+-- given constraint 'System'.+rankGoals :: GoalRanking -> System -> [AnnotatedGoal] -> [AnnotatedGoal]+rankGoals ranking = case ranking of+    GoalNrRanking       -> \_sys -> goalNrRanking+    UsefulGoalNrRanking ->+        \_sys -> sortOn (\(_, (nr, useless)) -> (useless, nr))+    SmartRanking useLoopsBreakers -> smartRanking useLoopsBreakers++-- | Use a 'GoalRanking' to generate the ranked, list of possible+-- 'ProofMethod's and their corresponding results in this 'ProofContext' and+-- for this 'System'. If the resulting list is empty, then the constraint+-- system is solved.+rankProofMethods :: GoalRanking -> ProofContext -> System+                 -> [(ProofMethod, (M.Map CaseName System, String))]+rankProofMethods ranking ctxt sys = do+    (m, expl) <-+            (contradiction <$> contradictions ctxt sys)+        <|> (case L.get pcUseInduction ctxt of+               AvoidInduction -> [(Simplify, ""), (Induction, "")]+               UseInduction   -> [(Induction, ""), (Simplify, "")]+            )+        <|> (solveGoalMethod <$> (rankGoals ranking sys $ openGoals sys))+    case execProofMethod ctxt m sys of+      Just cases -> return (m, (cases, expl))+      Nothing    -> []+  where+    contradiction c                    = (Contradiction (Just c), "")+    solveGoalMethod (goal, (nr, usefulness)) =+      ( SolveGoal goal+      , "nr. " ++ show nr ++ case usefulness of+                               Useful -> ""+                               Useless -> " (marked useless)"+      )++newtype Heuristic = Heuristic [GoalRanking]+    deriving( Eq, Ord, Show )++-- | Smart constructor for heuristics. Schedules the goal rankings in a+-- round-robin fashion dependent on the proof depth.+roundRobinHeuristic :: [GoalRanking] -> Heuristic+roundRobinHeuristic = Heuristic++-- | Use a heuristic to schedule a 'GoalRanking' according to the given+-- proof-depth.+useHeuristic :: Heuristic -> Int -> GoalRanking+useHeuristic (Heuristic []      ) = error "useHeuristic: empty list of rankings"+useHeuristic (Heuristic rankings) =+    ranking+  where+    n = length rankings++    ranking depth+      | depth < 0 = error $ "useHeuristic: negative proof depth " ++ show depth+      | otherwise = rankings !! (depth `mod` n)++++{-+-- | Schedule the given local-heuristics in a round-robin fashion.+roundRobinHeuristic :: [GoalRanking] -> Heuristic+roundRobinHeuristic []       = error "roundRobin: empty list of rankings"+roundRobinHeuristic rankings =+    methods+  where+    n = length rankings++    methods depth ctxt sys+      | depth < 0 = error $ "roundRobin: negative proof depth " ++ show depth+      | otherwise =+          ( name+          ,     ((Contradiction . Just) <$> contradictions ctxt sys)+            <|> (case L.get pcUseInduction ctxt of+                   AvoidInduction -> [Simplify, Induction]+                   UseInduction   -> [Induction, Simplify]+                )+            <|> ((SolveGoal . fst) <$> (ranking sys $ openGoals sys))+          )+      where+        (name, ranking) = rankings !! (depth `mod` n)+-}++-- | Sort annotated goals according to their number.+goalNrRanking :: [AnnotatedGoal] -> [AnnotatedGoal]+goalNrRanking = sortOn (fst . snd)++-- | A ranking function tuned for the automatic verification of+-- classical security protocols that exhibit a well-founded protocol premise+-- fact flow.+smartRanking :: Bool   -- True if PremiseG loop-breakers should not be delayed+             -> System+             -> [AnnotatedGoal] -> [AnnotatedGoal]+smartRanking allowPremiseGLoopBreakers sys =+    delayUseless . unmark . sortDecisionTree solveFirst . goalNrRanking+  where+    delayUseless = sortOn (snd . snd)++    unmark | allowPremiseGLoopBreakers = map unmarkPremiseG+           | otherwise                 = id++    unmarkPremiseG (goal@(PremiseG _ _), (nr, _)) = (goal, (nr, Useful))+    unmarkPremiseG annGoal                        = annGoal++    solveFirst =+        [ isChainGoal . fst+        , isDisjGoal . fst+        , isNonLoopBreakerProtoFactGoal+        , isStandardActionGoal . fst+        , isFreshKnowsGoal . fst+        , isSplitGoalSmall . fst+        , isDoubleExpGoal . fst+        , isLoopBreakerGoal ]+          -- prefer knowledge goals and loop-breaker premises+          -- before expensive equation splits++    isNonLoopBreakerProtoFactGoal (PremiseG _ fa, (_, Useful)) = not $ isKFact fa+    isNonLoopBreakerProtoFactGoal _                            = False++    msgPremise (ActionG _ fa) = do (UpK, _, m) <- kFactView fa; return m+    msgPremise _              = Nothing++    isFreshKnowsGoal goal = case msgPremise goal of+        Just (viewTerm -> Lit (Var lv)) | lvarSort lv == LSortFresh -> True+        _                                                           -> False++    isDoubleExpGoal goal = case msgPremise goal of+        Just (viewTerm2 -> FExp  _ (viewTerm2 -> FMult _)) -> True+        _                                                  -> False++    isLoopBreakerGoal (ActionG _ fa, _           ) = isKUFact fa+    isLoopBreakerGoal (PremiseG _ _, (_, Useless)) = True+    isLoopBreakerGoal _                            = False++    -- Be conservative on splits that don't exist.+    isSplitGoalSmall (SplitG sid) =+        maybe False (< 3) $ splitSize (L.get sEqStore sys) sid+    isSplitGoalSmall _            = False++    -- | @sortDecisionTree xs ps@ returns a reordering of @xs@+    -- such that the sublist satisfying @ps!!0@ occurs first,+    -- then the sublist satisfying @ps!!1@, and so on.+    sortDecisionTree :: [a -> Bool] -> [a] -> [a]+    sortDecisionTree []     xs = xs+    sortDecisionTree (p:ps) xs = sat ++ sortDecisionTree ps nonsat+      where (sat, nonsat) = partition p xs++++------------------------------------------------------------------------------+-- Pretty printing+------------------------------------------------------------------------------++-- | Pretty-print a proof method.+prettyProofMethod :: HighlightDocument d => ProofMethod -> d+prettyProofMethod method = case method of+    Solved               -> keyword_ "SOLVED" <-> lineComment_ "trace found"+    Induction            -> keyword_ "induction"+    Sorry reason         -> fsep [keyword_ "sorry", lineComment_ reason]+    SolveGoal goal       ->+        keyword_ "solve(" <-> prettyGoal goal <-> keyword_ ")"+    Simplify             -> keyword_ "simplify"+    Contradiction reason ->+        sep [ keyword_ "contradiction"+            , maybe emptyDoc (lineComment . prettyContradiction) reason+            ]++++-- Derived instances+--------------------++$( derive makeBinary ''ProofMethod)+$( derive makeBinary ''GoalRanking)+$( derive makeBinary ''Heuristic)++$( derive makeNFData ''ProofMethod)+$( derive makeNFData ''GoalRanking)+$( derive makeNFData ''Heuristic)
+ src/Theory/Constraint/Solver/Reduction.hs view
@@ -0,0 +1,661 @@+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ViewPatterns  #-}+-- |+-- Copyright   : (c) 2010-2012 Benedikt Schmidt & Simon Meier+-- License     : GPL v3 (see LICENSE)+--+-- Maintainer  : Simon Meier <iridcode@gmail.com>+-- Portability : GHC only+--+-- A monad for writing constraint reduction steps together with basic steps+-- for inserting nodes, edges, actions, and equations and applying+-- substitutions.+module Theory.Constraint.Solver.Reduction (+  -- * The constraint 'Reduction' monad+    Reduction+  , execReduction+  , runReduction++  -- ** Change management+  , ChangeIndicator(..)+  , whenChanged+  , applyChangeList+  , whileChanging++  -- ** Accessing the 'ProofContext'+  , getProofContext+  , getMaudeHandle++  -- ** Inserting nodes, edges, and atoms+  , labelNodeId+  , insertFreshNode+  , insertFreshNodeConc++  , insertGoal+  , insertAtom+  , insertEdges+  , insertChain+  , insertAction+  , insertLess+  , insertFormula+  , reducibleFormula++  -- ** Goal management+  , markGoalAsSolved+  , removeSolvedSplitGoals++  -- ** Substitution application+  , substSystem+  , substNodes+  , substEdges+  , substLastAtom+  , substLessAtoms+  , substFormulas+  , substSolvedFormulas++  -- ** Solving equalities+  , SplitStrategy(..)++  , solveNodeIdEqs+  , solveTermEqs+  , solveFactEqs+  , solveRuleEqs+  , solveSubstEqs++  -- ** Conjunction with another constraint 'System'+  , conjoinSystem++  -- ** Convenience export+  , module Logic.Connectives++  ) where++import           Debug.Trace+import           Prelude                                 hiding (id, (.))++import qualified Data.Foldable                           as F+import qualified Data.Map                                as M+import qualified Data.Set                                as S+import           Safe++import           Control.Basics+import           Control.Category+import           Control.Monad.Bind+import           Control.Monad.Disj+import           Control.Monad.Reader+import           Control.Monad.State                     (StateT, execStateT, gets, runStateT)++import           Text.PrettyPrint.Class++import           Extension.Data.Label+import           Extension.Data.Monoid                   (Monoid(..))+import           Extension.Prelude++import           Logic.Connectives++import           Theory.Constraint.Solver.Contradictions+import           Theory.Constraint.Solver.Types+import           Theory.Constraint.System+import           Theory.Model+++------------------------------------------------------------------------------+-- The constraint reduction monad+------------------------------------------------------------------------------++-- | A constraint reduction step. Its state is the current constraint system,+-- it can generate fresh names, split over cases, and access the proof+-- context.+type Reduction = StateT System (FreshT (DisjT (Reader ProofContext)))+++-- Executing reductions+-----------------------++-- | Run a constraint reduction. Returns a list of constraint systems whose+-- combined solutions are equal to the solutions of the given system. This+-- property is obviously not enforced, but it must be respected by all+-- functions of type 'Reduction'.+runReduction :: Reduction a -> ProofContext -> System -> FreshState+             -> Disj ((a, System), FreshState)+runReduction m ctxt se fs =+    Disj $ (`runReader` ctxt) $ runDisjT $ (`runFreshT` fs) $ runStateT m se++-- | Run a constraint reduction returning only the updated constraint systems+-- and the new freshness states.+execReduction :: Reduction a -> ProofContext -> System -> FreshState+              -> Disj (System, FreshState)+execReduction m ctxt se fs =+    Disj $ (`runReader` ctxt) . runDisjT . (`runFreshT` fs) $ execStateT m se+++-- Change management+--------------------++-- | Indicate whether the constraint system was changed or not.+data ChangeIndicator = Unchanged | Changed+       deriving( Eq, Ord, Show )++instance Monoid ChangeIndicator where+    mempty = Unchanged++    Changed   `mappend` _         = Changed+    _         `mappend` Changed   = Changed+    Unchanged `mappend` Unchanged = Unchanged++-- | Return 'True' iff there was a change.+wasChanged :: ChangeIndicator -> Bool+wasChanged Changed   = True+wasChanged Unchanged = False++-- | Only apply a monadic action, if there has been a change.+whenChanged :: Monad m => ChangeIndicator -> m () -> m ()+whenChanged = when . wasChanged++-- | Apply a list of changes to the proof state.+applyChangeList :: [Reduction ()] -> Reduction ChangeIndicator+applyChangeList []      = return Unchanged+applyChangeList changes = sequence_ changes >> return Changed++-- | Execute a 'Reduction' as long as it results in changes. Indicate whether+-- at least one change was performed.+whileChanging :: Reduction ChangeIndicator -> Reduction ChangeIndicator+whileChanging reduction =+    go Unchanged+  where+    go indicator = do indicator' <- reduction+                      case indicator' of+                          Unchanged -> return indicator+                          Changed   -> go     indicator'+++-- Accessing the proof context+------------------------------++-- | Retrieve the 'ProofContext'.+getProofContext :: Reduction ProofContext+getProofContext = ask++-- | Retrieve the 'MaudeHandle' from the 'ProofContext'.+getMaudeHandle :: Reduction MaudeHandle+getMaudeHandle = askM pcMaudeHandle+++-- Inserting (fresh) nodes into the constraint system+-----------------------------------------------------++-- | Insert a fresh rule node labelled with a fresh instance of one of the+-- rules and return one of the conclusions.+insertFreshNodeConc :: [RuleAC] -> Reduction (RuleACInst, NodeConc, LNFact)+insertFreshNodeConc rules = do+    (i, ru) <- insertFreshNode rules+    (v, fa) <- disjunctionOfList $ enumConcs ru+    return (ru, (i, v), fa)++-- | Insert a fresh rule node labelled with a fresh instance of one of the rules+-- and solve it's 'Fr', 'In', and 'KU' premises immediatly.+insertFreshNode :: [RuleAC] -> Reduction (NodeId, RuleACInst)+insertFreshNode rules = do+    i <- freshLVar "vr" LSortNode+    (,) i <$> labelNodeId i rules++-- | Label a node-id with a fresh instance of one of the rules and+-- solve it's 'Fr', 'In', and 'KU' premises immediatly.+--+-- PRE: Node must not yet be labelled with a rule.+labelNodeId :: NodeId -> [RuleAC] -> Reduction RuleACInst+labelNodeId = \i rules -> do+    (ru, mrconstrs) <- importRule =<< disjunctionOfList rules+    solveRuleConstraints mrconstrs+    modM sNodes (M.insert i ru)+    exploitPrems i ru+    return ru+  where+    -- | Import a rule with all its variables renamed to fresh variables.+    importRule ru = someRuleACInst ru `evalBindT` noBindings++    mkISendRuleAC m = do+        faPrem <- kuFact Nothing m+        return $ Rule (IntrInfo (ISendRule))+                      [faPrem] [inFact m] [kLogFact m]++    mkFreshRuleAC m = Rule (ProtoInfo (ProtoRuleACInstInfo FreshRule []))+                           [] [freshFact m] []++    exploitPrems i ru = mapM_ (exploitPrem i ru) (enumPrems ru)++    exploitPrem i ru (v, fa) = case fa of+        -- CR-rule *DG2_2* specialized for *In* facts.+        Fact InFact [m] -> do+            j <- freshLVar "vf" LSortNode+            ruKnows <- mkISendRuleAC m+            modM sNodes (M.insert j ruKnows)+            modM sEdges (S.insert $ Edge (j, ConcIdx 0) (i, v))+            exploitPrems j ruKnows++        -- CR-rule *DG2_2* specialized for *Fr* facts.+        Fact FreshFact [m] -> do+            j <- freshLVar "vf" LSortNode+            modM sNodes (M.insert j (mkFreshRuleAC m))+            unless (isFreshVar m) $ do+                -- 'm' must be of sort fresh ==> enforce via unification+                n <- varTerm <$> freshLVar "n" LSortFresh+                void (solveTermEqs SplitNow [Equal m n])+            modM sEdges (S.insert $ Edge (j, ConcIdx 0) (i,v))++          -- CR-rule *DG2_{2,u}*: solve a KU-premise by inserting the+          -- corresponding KU-actions before this node.+        _ | isKUFact fa -> do+              j <- freshLVar "vk" LSortNode+              insertLess j i+              void (insertAction j fa)++          -- Store premise goal for later processing using CR-rule *DG2_2*+          | otherwise -> insertGoal (PremiseG (i,v) fa) (v `elem` breakers)+      where+        breakers = ruleInfo (get praciLoopBreakers) (const []) $ get rInfo ru++-- | Insert a chain constrain.+insertChain :: NodeConc -> NodePrem -> Reduction ()+insertChain c p = insertGoal (ChainG c p) False++-- | Insert an edge constraint. CR-rule *DG1_2* is enforced automatically,+-- i.e., the fact equalities are enforced.+insertEdges :: [(NodeConc, LNFact, LNFact, NodePrem)] -> Reduction ()+insertEdges edges = do+    void (solveFactEqs SplitNow [ Equal fa1 fa2 | (_, fa1, fa2, _) <- edges ])+    modM sEdges (\es -> foldr S.insert es [ Edge c p | (c,_,_,p) <- edges])++-- | Insert an 'Action' atom. Ensures that (almost all) trivial *KU* actions+-- are solved immediatly using rule *S_{at,u,triv}*. We currently avoid+-- adding intermediate products. Indicates whether nodes other than the given+-- action have been added to the constraint system.+--+-- FIXME: Ensure that intermediate products are also solved before stating+-- that no rule is applicable.+insertAction :: NodeId -> LNFact -> Reduction ChangeIndicator+insertAction i fa = do+    present <- (goal `M.member`) <$> getM sGoals+    if present+      then do return Unchanged+      else do insertGoal goal False+              case kFactView fa of+                Just (UpK, _, viewTerm2 -> FPair m1 m2) ->+                    requiresKU m1 *> requiresKU m2 *> return Changed++                Just (UpK, _, viewTerm2 -> FInv m) ->+                    requiresKU m *> return Changed++                Just (UpK, _, viewTerm2 -> FMult ms) ->+                    mapM_ requiresKU ms *> return Changed++                _ -> return Unchanged+  where+    goal = ActionG i fa+    -- Here we rely on the fact that the action is new. Otherwise, we might+    -- loop due to generating new KU-nodes that are merged immediatly.+    requiresKU t = do+      j <- freshLVar "vk" LSortNode+      faKU <- kuFact Nothing t+      insertLess j i+      void (insertAction j faKU)++-- | Insert a 'Less' atom. @insertLess i j@ means that *i < j* is added.+insertLess :: NodeId -> NodeId -> Reduction ()+insertLess i j = modM sLessAtoms (S.insert (i, j))++-- | Insert a 'Last' atom and ensure their uniqueness.+insertLast :: NodeId -> Reduction ChangeIndicator+insertLast i = do+    lst <- getM sLastAtom+    case lst of+      Nothing -> setM sLastAtom (Just i) >> return Unchanged+      Just j  -> solveNodeIdEqs [Equal i j]++-- | Insert an atom. Returns 'Changed' if another part of the constraint+-- system than the set of actions was changed.+insertAtom :: LNAtom -> Reduction ChangeIndicator+insertAtom ato = case ato of+    EqE x y       -> solveTermEqs SplitNow [Equal x y]+    Action i fa   -> insertAction (ltermNodeId' i) fa+    Less i j      -> do insertLess (ltermNodeId' i) (ltermNodeId' j)+                        return Unchanged+    Last i        -> insertLast (ltermNodeId' i)++-- | Insert a 'Guarded' formula. Ensures that existentials, conjunctions, negated+-- last atoms, and negated less atoms, are immediately solved using the rules+-- *S_exists*, *S_and*, *S_not,last*, and *S_not,less*. Only the inserted+-- formula is marked as solved. Other intermediate formulas are not marked.+insertFormula :: LNGuarded -> Reduction ()+insertFormula = do+    insert True+  where+    insert mark fm = do+        formulas       <- getM sFormulas+        solvedFormulas <- getM sSolvedFormulas+        insert' mark formulas solvedFormulas fm++    insert' mark formulas solvedFormulas fm+      | fm `S.member` formulas       = return ()+      | fm `S.member` solvedFormulas = return ()+      | otherwise = case fm of+          GAto ato -> do+              markAsSolved+              void (insertAtom (bvarToLVar ato))++          -- CR-rule *S_∧*+          GConj fms -> do+              markAsSolved+              mapM_ (insert False) (getConj fms)++          -- Store for later applications of CR-rule *S_∨*+          GDisj disj -> do+              modM sFormulas (S.insert fm)+              insertGoal (DisjG disj) False++          -- CR-rule *S_∃*+          GGuarded Ex ss as gf -> do+              -- must always mark as solved, as we otherwise may repeatedly+              -- introduce fresh variables.+              modM sSolvedFormulas $ S.insert fm+              xs <- mapM (uncurry freshLVar) ss+              let body = gconj (map GAto as ++ [gf])+              insert False (substBound (zip [0..] (reverse xs)) body)++          -- CR-rule *S_{¬,⋖}*+          GGuarded All [] [Less i j] gf  | gf == gfalse -> do+              markAsSolved+              insert False (gdisj [GAto (EqE i j), GAto (Less j i)])++          -- CR-rule: FIXME add this rule to paper+          GGuarded All [] [EqE i@(bltermNodeId -> Just _)+                               j@(bltermNodeId -> Just _) ] gf+            | gf == gfalse -> do+                markAsSolved+                insert False (gdisj [GAto (Less i j), GAto (Less j i)])++          -- CR-rule *S_{¬,last}*+          GGuarded All [] [Last i]   gf  | gf == gfalse -> do+              markAsSolved+              lst <- getM sLastAtom+              j <- case lst of+                     Nothing  -> do j <- freshLVar "last" LSortNode+                                    void (insertLast j)+                                    return (varTerm (Free j))+                     Just j -> return (varTerm (Free j))+              insert False $ gdisj [ GAto (Less j i), GAto (Less i j) ]++          -- Guarded All quantification: store for saturation+          GGuarded All _ _ _ -> modM sFormulas (S.insert fm)+      where+        markAsSolved = when mark $ modM sSolvedFormulas $ S.insert fm++-- | 'True' iff the formula can be reduced by one of the rules implemented in+-- 'insertFormula'.+reducibleFormula :: LNGuarded -> Bool+reducibleFormula fm = case fm of+    GAto _                        -> True+    GConj _                       -> True+    GGuarded Ex _ _ _             -> True+    GGuarded All [] [Less _ _] gf -> gf == gfalse+    GGuarded All [] [Last _]   gf -> gf == gfalse+    _                             -> False+++-- Goal management+------------------++-- | Combine the status of two goals.+combineGoalStatus :: GoalStatus -> GoalStatus -> GoalStatus+combineGoalStatus (GoalStatus solved1 age1 loops1)+                  (GoalStatus solved2 age2 loops2) =+    GoalStatus (solved1 || solved2) (min age1 age2) (loops1 || loops2)++-- | Insert a goal and its status with a new age. Merge status if goal exists.+insertGoalStatus :: Goal -> GoalStatus -> Reduction ()+insertGoalStatus goal status = do+    age <- getM sNextGoalNr+    modM sGoals $ M.insertWith' combineGoalStatus goal (set gsNr age status)+    sNextGoalNr =: succ age++-- | Insert a 'Goal' and store its age.+insertGoal :: Goal -> Bool -> Reduction ()+insertGoal goal looping = insertGoalStatus goal (GoalStatus False 0 looping)++-- | Mark the given goal as solved.+markGoalAsSolved :: String -> Goal -> Reduction ()+markGoalAsSolved how goal =+    case goal of+      ActionG _ _     -> updateStatus+      PremiseG _ fa+        | isKDFact fa -> modM sGoals $ M.delete goal+        | otherwise   -> updateStatus+      ChainG _ _      -> modM sGoals $ M.delete goal+      SplitG _        -> updateStatus+      DisjG disj      -> modM sFormulas       (S.delete $ GDisj disj) >>+                         modM sSolvedFormulas (S.insert $ GDisj disj) >>+                         updateStatus+  where+    updateStatus = do+        mayStatus <- M.lookup goal <$> getM sGoals+        case mayStatus of+          Just status -> trace (msg status) $+              modM sGoals $ M.insert goal $ set gsSolved True status+          Nothing     -> trace ("markGoalAsSolved: inexistent goal " ++ show goal) $ return ()++    msg status = render $ nest 2 $ fsep $+        [ text ("solved goal nr. "++ show (get gsNr status))+          <-> parens (text how) <> colon+        , nest 2 (prettyGoal goal) ]++removeSolvedSplitGoals :: Reduction ()+removeSolvedSplitGoals = do+    goals    <- getM sGoals+    existent <- splitExists <$> getM sEqStore+    sequence_ [ modM sGoals $ M.delete goal+              | goal@(SplitG i) <- M.keys goals, not (existent i) ]+++-- Substitution+---------------++-- | Apply the current substitution of the equation store to the remainder of+-- the sequent.+substSystem :: Reduction ChangeIndicator+substSystem = do+    c1 <- substNodes+    substEdges+    substLastAtom+    substLessAtoms+    substFormulas+    substSolvedFormulas+    substLemmas+    c2 <- substGoals+    substNextGoalNr+    return (c1 <> c2)++-- no invariants to maintain here+substEdges, substLessAtoms, substLastAtom, substFormulas,+  substSolvedFormulas, substLemmas, substNextGoalNr :: Reduction ()++substEdges          = substPart sEdges+substLessAtoms      = substPart sLessAtoms+substLastAtom       = substPart sLastAtom+substFormulas       = substPart sFormulas+substSolvedFormulas = substPart sSolvedFormulas+substLemmas         = substPart sLemmas+substNextGoalNr     = return ()+++-- | Apply the current substitution of the equation store to a part of the+-- sequent. This is an internal function.+substPart :: Apply a => (System :-> a) -> Reduction ()+substPart l = do subst <- getM sSubst+                 modM l (apply subst)++-- | Apply the current substitution of the equation store the nodes of the+-- constraint system. Indicates whether additional equalities were added to+-- the equations store.+substNodes :: Reduction ChangeIndicator+substNodes =+    substNodeIds <* ((modM sNodes . M.map . apply) =<< getM sSubst)++-- | @setNodes nodes@ normalizes the @nodes@ such that node ids are unique and+-- then updates the @sNodes@ field of the proof state to the corresponding map.+-- Return @True@ iff new equalities have been added to the equation store.+setNodes :: [(NodeId, RuleACInst)] -> Reduction ChangeIndicator+setNodes nodes0 = do+    sNodes =: M.fromList nodes+    if null ruleEqs then                                    return Unchanged+                    else solveRuleEqs SplitLater ruleEqs >> return Changed+  where+    -- merge nodes with equal node id+    (ruleEqs, nodes) = first concat $ unzip $ map merge $ groupSortOn fst nodes0++    merge []            = unreachable "setNodes"+    merge (keep:remove) = (map (Equal (snd keep) . snd) remove, keep)++-- | Apply the current substitution of the equation store to the node ids and+-- ensure uniqueness of the labels, as required by rule *U_lbl*. Indicates+-- whether there where new equalities added to the equations store.+substNodeIds :: Reduction ChangeIndicator+substNodeIds =+    whileChanging $ do+        subst <- getM sSubst+        nodes <- gets (map (first (apply subst)) . M.toList . get sNodes)+        setNodes nodes++-- | Substitute all goals. Keep the ones with the lower nr.+substGoals :: Reduction ChangeIndicator+substGoals = do+    subst <- getM sSubst+    goals <- M.toList <$> getM sGoals+    sGoals =: M.empty+    changes <- forM goals $ \(goal, status) -> case goal of+        -- Look out for KU-actions that might need to be solved again.+        ActionG i fa@(kFactView -> Just (UpK, _, m))+          | (isMsgVar m || isProduct m) && (apply subst m /= m) ->+              insertAction i (apply subst fa)+        _ -> do modM sGoals $+                  M.insertWith' combineGoalStatus (apply subst goal) status+                return Unchanged++    return (mconcat changes)+++-- Conjoining two constraint systems+------------------------------------++-- | @conjoinSystem se@ conjoins the logical information in @se@ to the+-- constraint system. It assumes that the free variables in @se@ are shared+-- with the free variables in the proof state.+conjoinSystem :: System -> Reduction ()+conjoinSystem sys = do+    kind <- getM sCaseDistKind+    unless (kind == get sCaseDistKind sys) $+        error "conjoinSystem: typing-kind mismatch"+    joinSets sSolvedFormulas+    joinSets sLemmas+    joinSets sEdges+    F.mapM_ insertLast                 $ get sLastAtom    sys+    F.mapM_ (uncurry insertLess)       $ get sLessAtoms   sys+    mapM_   (uncurry insertGoalStatus) $ M.toList $ get sGoals sys+    F.mapM_ insertFormula $ get sFormulas sys+    -- update nodes+    _ <- (setNodes . (M.toList (get sNodes sys) ++) . M.toList) =<< getM sNodes+    -- conjoin equation store+    modM sConjDisjEqs (`mappend` get sConjDisjEqs sys)+    void (solveSubstEqs SplitNow $ get sSubst sys)+    -- Propagate substitution changes. Ignore change indicator, as it is+    -- assumed to be 'Changed' by default.+    void substSystem+  where+    joinSets :: Ord a => (System :-> S.Set a) -> Reduction ()+    joinSets proj = modM proj (`S.union` get proj sys)++++-- Unification via the equation store+-------------------------------------++-- | 'SplitStrategy' denotes if the equation store should be split into+-- multiple equation stores.+data SplitStrategy = SplitNow | SplitLater++-- The 'ChangeIndicator' indicates whether at least one non-trivial equality+-- was solved.++-- | @noContradictoryEqStore@ suceeds iff the equation store is not+-- contradictory.+noContradictoryEqStore :: Reduction ()+noContradictoryEqStore = (contradictoryIf . eqsIsFalse) =<< getM sEqStore++-- | Add a list of term equalities to the equation store. And+--  split resulting disjunction of equations according+--  to given split strategy.+--+-- Note that updating the remaining parts of the constraint system with the+-- substitution has to be performed using a separate call to 'substSystem'.+solveTermEqs :: SplitStrategy -> [Equal LNTerm] -> Reduction ChangeIndicator+solveTermEqs splitStrat eqs0 =+    case filter (not . evalEqual) eqs0 of+      []  -> do return Unchanged+      eqs1 -> do+        hnd <- getMaudeHandle+        se  <- gets id+        (eqs2, maySplitId) <- addEqs hnd eqs1 =<< getM sEqStore+        setM sEqStore+            =<< simp hnd (substCreatesNonNormalTerms hnd se)+            =<< case (maySplitId, splitStrat) of+                  (Just splitId, SplitNow) -> disjunctionOfList+                                                $ fromJustNote "solveTermEqs"+                                                $ performSplit eqs2 splitId+                  (Just splitId, SplitLater) -> do+                      insertGoal (SplitG splitId) False+                      return eqs2+                  _                        -> return eqs2+        noContradictoryEqStore+        return Changed++-- | Add a list of equalities in substitution form to the equation store+solveSubstEqs :: SplitStrategy -> LNSubst -> Reduction ChangeIndicator+solveSubstEqs split subst =+    solveTermEqs split [Equal (varTerm v) t | (v, t) <- substToList subst]++-- | Add a list of node equalities to the equation store.+solveNodeIdEqs :: [Equal NodeId] -> Reduction ChangeIndicator+solveNodeIdEqs = solveTermEqs SplitNow . map (fmap varTerm)++-- | Add a list of fact equalities to the equation store, if possible.+solveFactEqs :: SplitStrategy -> [Equal LNFact] -> Reduction ChangeIndicator+solveFactEqs split eqs = do+    contradictoryIf (not $ all evalEqual $ map (fmap factTag) eqs)+    solveListEqs (solveTermEqs split) $ map (fmap factTerms) eqs++-- | Add a list of rule equalities to the equation store, if possible.+solveRuleEqs :: SplitStrategy -> [Equal RuleACInst] -> Reduction ChangeIndicator+solveRuleEqs split eqs = do+    contradictoryIf (not $ all evalEqual $ map (fmap (get rInfo)) eqs)+    solveListEqs (solveFactEqs split) $+        map (fmap (get rConcs)) eqs ++ map (fmap (get rPrems)) eqs++-- | Solve a number of equalities between lists interpreted as free terms+-- using the given solver for solving the entailed per-element equalities.+solveListEqs :: ([Equal a] -> Reduction b) -> [(Equal [a])] -> Reduction b+solveListEqs solver eqs = do+    contradictoryIf (not $ all evalEqual $ map (fmap length) eqs)+    solver $ concatMap flatten eqs+  where+    flatten (Equal l r) = zipWith Equal l r++-- | Solve the constraints associated with a rule.+solveRuleConstraints :: Maybe RuleACConstrs -> Reduction ()+solveRuleConstraints (Just eqConstr) = do+    hnd <- getMaudeHandle+    (eqs, splitId) <- addRuleVariants eqConstr <$> getM sEqStore+    insertGoal (SplitG splitId) False+    -- do not use expensive substCreatesNonNormalTerms here+    setM sEqStore =<< simp hnd (const False) eqs+    noContradictoryEqStore+solveRuleConstraints Nothing = return ()+
+ src/Theory/Constraint/Solver/Simplify.hs view
@@ -0,0 +1,445 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE ViewPatterns       #-}+-- |+-- Copyright   : (c) 2010-2012 Benedikt Schmidt & Simon Meier+-- License     : GPL v3 (see LICENSE)+--+-- Maintainer  : Simon Meier <iridcode@gmail.com>+-- Portability : GHC only+--+-- This module implements all rules that do not result in case distinctions+-- and equation solving. Some additional cases may although result from+-- splitting over multiple AC-unifiers. Note that a few of these rules are+-- implemented directly in the methods for inserting constraints to the+-- constraint system.  These methods are provided by+-- "Theory.Constraint.Solver.Reduction".+--+module Theory.Constraint.Solver.Simplify (++  simplifySystem++  ) where++import           Debug.Trace++import           Prelude                            hiding (id, (.))++import qualified Data.DAG.Simple                    as D+import           Data.Data+import           Data.Either                        (partitionEithers)+import qualified Data.Foldable                      as F+import           Data.List+import qualified Data.Map                           as M+import           Data.Monoid                        (Monoid(..))+import qualified Data.Set                           as S++import           Control.Basics+import           Control.Category+import           Control.Monad.Disj+import           Control.Monad.Fresh+import           Control.Monad.Reader+import           Control.Monad.State                (gets)++import           Text.PrettyPrint.Class++import           Extension.Data.Label+import           Extension.Prelude++import           Theory.Constraint.Solver.Goals+import           Theory.Constraint.Solver.Reduction+import           Theory.Constraint.Solver.Types+import           Theory.Constraint.System+import           Theory.Model+++-- | Apply CR-rules that don't result in case splitting until the constraint+-- system does not change anymore.+simplifySystem :: Reduction ()+simplifySystem = do+    -- Start simplification, indicating that some change happened+    go (0 :: Int) [Changed]+    -- Add all ordering constraint implied by CR-rule *N6*.+    exploitUniqueMsgOrder+    -- Remove equation split goals that do not exist anymore+    removeSolvedSplitGoals+  where+    go n changes0+      -- We stop as soon as all simplification steps have been run without+      -- reporting any change to the constraint systemm.+      | Unchanged == mconcat changes0 = return ()+      | otherwise                     = do+          -- Store original system for reporting+          se0 <- gets id+          -- Perform one initial substitution. We do not have to consider its+          -- changes as 'substSystem' is idempotent.+          void substSystem+          -- Perform one simplification pass.+          (c1,c2,c3) <- enforceNodeUniqueness+          c4 <- enforceEdgeUniqueness+          c5 <- solveUniqueActions+          c6 <- reduceFormulas+          c7 <- evalFormulaAtoms+          c8 <- insertImpliedFormulas++          -- Report on looping behaviour if necessary+          let changes = [c1, c2, c3, c4, c5, c6, c7, c8]+              traceIfLooping+                | n <= 10   = id+                | otherwise = trace $ render $ vcat+                    [ text "Simplifier iteration" <-> int n <> colon+                    , nest 2 (text (show changes))+                    , nest 2 (prettySystem se0)+                    ]++          traceIfLooping $ go (n + 1) changes+++-- | CR-rule *N6*: add ordering constraints between all KU-actions and+-- KD-conclusions.+exploitUniqueMsgOrder :: Reduction ()+exploitUniqueMsgOrder = do+    kdConcs   <- gets (M.fromList . map (\(i, _, m) -> (m, i)) . allKDConcs)+    kuActions <- gets (M.fromList . map (\(i, _, m) -> (m, i)) . allKUActions)+    -- We can add all elements where we have an intersection+    F.mapM_ (uncurry insertLess) $ M.intersectionWith (,) kdConcs kuActions++-- | CR-rules *DG4*, *N5_u*, and *N5_d*: enforcing uniqueness of *Fresh* rule+-- instances, *KU*-actions, and *KD*-conclusions.+--+-- Returns 'Changed' if a change was done.+enforceNodeUniqueness :: Reduction (ChangeIndicator, ChangeIndicator, ChangeIndicator)+enforceNodeUniqueness =+    (,,)+      <$> (merge (const $ return Unchanged) freshRuleInsts)+      <*> (merge (solveRuleEqs SplitNow)    kdConcs)+      <*> (merge (solveFactEqs SplitNow)    kuActions)+  where+    -- *DG4*+    freshRuleInsts se = do+        (i, ru) <- M.toList $ get sNodes se+        guard (isFreshRule ru)+        return (ru, ((), i))  -- no need to merge equal rules++    -- *N5_d*+    kdConcs sys = (\(i, ru, m) -> (m, (ru, i))) <$> allKDConcs sys++    -- *N5_u*+    kuActions se = (\(i, fa, m) -> (m, (fa, i))) <$> allKUActions se++    merge :: Ord b+          => ([Equal a] -> Reduction ChangeIndicator)+             -- ^ Equation solver for 'Equal a'+          -> (System -> [(b,(a,NodeId))])+             -- ^ Candidate selector+          -> Reduction ChangeIndicator                  --+    merge solver candidates = do+        changes <- gets (map mergers . groupSortOn fst . candidates)+        mconcat <$> sequence changes+      where+        mergers []                          = unreachable "enforceUniqueness"+        mergers ((_,(xKeep, iKeep)):remove) =+            mappend <$> solver         (map (Equal xKeep . fst . snd) remove)+                    <*> solveNodeIdEqs (map (Equal iKeep . snd . snd) remove)+++-- | CR-rules *DG2_1* and *DG3*: merge multiple incoming edges to all facts+-- and multiple outgoing edges from linear facts.+enforceEdgeUniqueness :: Reduction ChangeIndicator+enforceEdgeUniqueness = do+    se <- gets id+    let edges = S.toList (get sEdges se)+    (<>) <$> mergeNodes eSrc eTgt edges+         <*> mergeNodes eTgt eSrc (filter (proveLinearConc se . eSrc) edges)+  where+    -- | @proveLinearConc se (v,i)@ tries to prove that the @i@-th+    -- conclusion of node @v@ is a linear fact.+    proveLinearConc se (v, i) =+        maybe False (isLinearFact . (get (rConc i))) $+            M.lookup v $ get sNodes se++    -- merge the nodes on the 'mergeEnd' for edges that are equal on the+    -- 'compareEnd'+    mergeNodes mergeEnd compareEnd edges+      | null eqs  = return Unchanged+      | otherwise = do+            -- all indices of merged premises and conclusions must be equal+            contradictoryIf (not $ and [snd l == snd r | Equal l r <- eqs])+            -- nodes must be equal+            solveNodeIdEqs $ map (fmap fst) eqs+      where+        eqs = concatMap (merge mergeEnd) $ groupSortOn compareEnd edges++        merge _    []            = error "exploitEdgeProps: impossible"+        merge proj (keep:remove) = map (Equal (proj keep) . proj) remove++-- | Special version of CR-rule *S_at*, which is only applied to solve actions+-- that are guaranteed not to result in case splits.+solveUniqueActions :: Reduction ChangeIndicator+solveUniqueActions = do+    rules       <- nonSilentRules <$> askM pcRules+    actionAtoms <- gets unsolvedActionAtoms++    -- FIXME: We might cache the result of this static computation in the+    -- proof-context, e.g., in the 'ClassifiedRules'.+    let uniqueActions = [ x | [x] <- group (sort ruleActions) ]+        ruleActions   = [ (tag, length ts)+                        | ru <- rules, Fact tag ts <- get rActs ru ]++        isUnique (Fact tag ts) = (tag, length ts) `elem` uniqueActions++        trySolve (i, fa)+          | isUnique fa = solveGoal (ActionG i fa) >> return Changed+          | otherwise   = return Unchanged++    mconcat <$> mapM trySolve actionAtoms++-- | Reduce all formulas as far as possible. See 'insertFormula' for the+-- CR-rules exploited in this step. Note that this step is normally only+-- required to decompose the formula in the initial constraint system.+reduceFormulas :: Reduction ChangeIndicator+reduceFormulas = do+    formulas <- getM sFormulas+    applyChangeList $ do+        fm <- S.toList formulas+        guard (reducibleFormula fm)+        return $ do modM sFormulas $ S.delete fm+                    insertFormula fm++-- | Try to simplify the atoms contained in the formulas. See+-- 'partialAtomValuation' for an explanation of what CR-rules are exploited+-- here.+evalFormulaAtoms :: Reduction ChangeIndicator+evalFormulaAtoms = do+    ctxt      <- ask+    valuation <- gets (partialAtomValuation ctxt)+    formulas  <- getM sFormulas+    applyChangeList $ do+        fm <- S.toList formulas+        case simplifyGuarded valuation fm of+          Just fm' -> return $ do+              case fm of+                GDisj disj -> markGoalAsSolved "simplified" (DisjG disj)+                _          -> return ()+              modM sFormulas       $ S.delete fm+              modM sSolvedFormulas $ S.insert fm+              insertFormula fm'+          Nothing  -> []++-- | A partial valuation for atoms. The return value of this function is+-- interpreted as follows.+--+-- @partialAtomValuation ctxt sys ato == Just True@ if for every valuation+-- @theta@ satisfying the graph constraints and all atoms in the constraint+-- system @sys@, the atom @ato@ is also satisfied by @theta@.+--+-- The interpretation for @Just False@ is analogous. @Nothing@ is used to+-- represent *unknown*.+--+partialAtomValuation :: ProofContext -> System -> LNAtom -> Maybe Bool+partialAtomValuation ctxt sys =+    eval+  where+    runMaude   = (`runReader` get pcMaudeHandle ctxt)+    before     = alwaysBefore sys+    lessRel    = rawLessRel sys+    nodesAfter = \i -> filter (i /=) $ S.toList $ D.reachableSet [i] lessRel++    -- | 'True' iff there in every solution to the system the two node-ids are+    -- instantiated to a different index *in* the trace.+    nonUnifiableNodes :: NodeId -> NodeId -> Bool+    nonUnifiableNodes i j = maybe False (not . runMaude) $+        (unifiableRuleACInsts) <$> M.lookup i (get sNodes sys)+                               <*> M.lookup j (get sNodes sys)++    -- | Try to evaluate the truth value of this atom in all models of the+    -- constraint system 'sys'.+    eval ato = case ato of+          Action (ltermNodeId' -> i) fa+            | ActionG i fa `M.member` get sGoals sys -> Just True+            | otherwise ->+                case M.lookup i (get sNodes sys) of+                  Just ru+                    | any (fa ==) (get rActs ru)                                -> Just True+                    | all (not . runMaude . unifiableLNFacts fa) (get rActs ru) -> Just False+                  _                                                             -> Nothing++          Less (ltermNodeId' -> i) (ltermNodeId' -> j)+            | i == j || j `before` i             -> Just False+            | i `before` j                       -> Just True+            | isLast sys i && isInTrace sys j    -> Just False+            | isLast sys j && isInTrace sys i &&+              nonUnifiableNodes i j              -> Just True+            | otherwise                          -> Nothing++          EqE x y+            | x == y                                -> Just True+            | not (runMaude (unifiableLNTerms x y)) -> Just False+            | otherwise                             ->+                case (,) <$> ltermNodeId x <*> ltermNodeId y of+                  Just (i, j)+                    | i `before` j || j `before` i  -> Just False+                    | nonUnifiableNodes i j         -> Just False+                  _                                 -> Nothing++          Last (ltermNodeId' -> i)+            | isLast sys i                       -> Just True+            | any (isInTrace sys) (nodesAfter i) -> Just False+            | otherwise ->+                case get sLastAtom sys of+                  Just j | nonUnifiableNodes i j -> Just False+                  _                              -> Nothing++++-- | CR-rule *S_∀*: insert all newly implied formulas.+insertImpliedFormulas :: Reduction ChangeIndicator+insertImpliedFormulas = do+    sys <- gets id+    hnd <- getMaudeHandle+    applyChangeList $ do+        clause  <- (S.toList $ get sFormulas sys) +++                   (S.toList $ get sLemmas sys)+        implied <- impliedFormulas hnd sys clause+        if ( implied `S.notMember` get sFormulas sys &&+             implied `S.notMember` get sSolvedFormulas sys )+          then return (insertFormula implied)+          else []++-- | @impliedFormulas se imp@ returns the list of guarded formulas that are+-- implied by @se@.+impliedFormulas :: MaudeHandle -> System -> LNGuarded -> [LNGuarded]+impliedFormulas hnd sys gf0 =+    case openGuarded gf `evalFresh` avoid gf of+      Just (All, _vs, antecedent, succedent) -> do+        let (actions, otherAtoms) = partitionEithers $ map prepare antecedent+            succedent'             = gall [] otherAtoms succedent+        subst <- candidateSubsts emptySubst actions+        return $ unskolemizeLNGuarded $ applySkGuarded subst succedent'+      _ -> []+  where+    gf = skolemizeGuarded gf0++    prepare (Action i fa) = Left (i, fa)+    prepare ato           = Right (fmap (fmapTerm (fmap Free)) ato)++    sysActions = do (i, fa) <- allActions sys+                    return (skolemizeTerm (varTerm i), skolemizeFact fa)++    candidateSubsts subst []     = do+        return subst+    candidateSubsts subst (a:as) = do+        sysAct <- sysActions+        subst' <- (`runReader` hnd) $ matchAction sysAct (applySkAction subst a)+        candidateSubsts (compose subst' subst) as+++------------------------------------------------------------------------------+-- Terms, facts, and formulas with skolem constants+------------------------------------------------------------------------------++-- | A constant type that supports names and skolem constants. We use the+-- skolem constants to represent fixed free variables from the constraint+-- system during matching the atoms of a guarded clause to the atoms of the+-- constraint system.+data SkConst = SkName  Name+             | SkConst LVar+             deriving( Eq, Ord, Show, Data, Typeable )++type SkTerm    = VTerm SkConst LVar+type SkFact    = Fact SkTerm+type SkSubst   = Subst SkConst LVar+type SkGuarded = LGuarded SkConst++-- | A term with skolem constants and bound variables+type BSkTerm   = VTerm SkConst BLVar++-- | An term with skolem constants and bound variables+type BSkAtom   = Atom BSkTerm++instance IsConst SkConst+++-- Skolemization of terms without bound variables.+--------------------------------------------------++skolemizeTerm :: LNTerm -> SkTerm+skolemizeTerm = fmapTerm conv+ where+  conv :: Lit Name LVar -> Lit SkConst LVar+  conv (Var v) = Con (SkConst v)+  conv (Con n) = Con (SkName n)++skolemizeFact :: LNFact -> Fact SkTerm+skolemizeFact = fmap skolemizeTerm++skolemizeAtom :: BLAtom -> BSkAtom+skolemizeAtom = fmap skolemizeBTerm++skolemizeGuarded :: LNGuarded -> SkGuarded+skolemizeGuarded = mapGuardedAtoms (const skolemizeAtom)++applySkTerm :: SkSubst -> SkTerm -> SkTerm+applySkTerm subst t = applyVTerm subst t++applySkFact :: SkSubst -> SkFact -> SkFact+applySkFact subst = fmap (applySkTerm subst)++applySkAction :: SkSubst -> (SkTerm,SkFact) -> (SkTerm,SkFact)+applySkAction subst (t,f) = (applySkTerm subst t, applySkFact subst f)+++-- Skolemization of terms with bound variables.+-----------------------------------------------++skolemizeBTerm :: VTerm Name BLVar -> BSkTerm+skolemizeBTerm = fmapTerm conv+ where+  conv :: Lit Name BLVar -> Lit SkConst BLVar+  conv (Var (Free x))  = Con (SkConst x)+  conv (Var (Bound b)) = Var (Bound b)+  conv (Con n)         = Con (SkName n)++unskolemizeBTerm :: BSkTerm -> VTerm Name BLVar+unskolemizeBTerm t = fmapTerm conv t+ where+  conv :: Lit SkConst BLVar -> Lit Name BLVar+  conv (Con (SkConst x)) = Var (Free x)+  conv (Var (Bound b))   = Var (Bound b)+  conv (Var (Free v))    = error $ "unskolemizeBTerm: free variable " +++                                   show v++" found in "++show t+  conv (Con (SkName n))  = Con n++unskolemizeBLAtom :: BSkAtom -> BLAtom+unskolemizeBLAtom = fmap unskolemizeBTerm++unskolemizeLNGuarded :: SkGuarded -> LNGuarded+unskolemizeLNGuarded = mapGuardedAtoms (const unskolemizeBLAtom)++applyBSkTerm :: SkSubst -> VTerm SkConst BLVar -> VTerm SkConst BLVar+applyBSkTerm subst =+    go+  where+    go t = case viewTerm t of+      Lit l     -> applyBLLit l+      FApp o as -> fApp o (map go as)++    applyBLLit :: Lit SkConst BLVar -> VTerm SkConst BLVar+    applyBLLit l@(Var (Free v)) =+        maybe (lit l) (fmapTerm (fmap Free)) (imageOf subst v)+    applyBLLit l                = lit l++applyBSkAtom :: SkSubst -> Atom (VTerm SkConst BLVar) -> Atom (VTerm SkConst BLVar)+applyBSkAtom subst = fmap (applyBSkTerm subst)++applySkGuarded :: SkSubst -> LGuarded SkConst -> LGuarded SkConst+applySkGuarded subst = mapGuardedAtoms (const $ applyBSkAtom subst)++-- Matching+-----------++matchAction :: (SkTerm, SkFact) ->  (SkTerm, SkFact) -> WithMaude [SkSubst]+matchAction (i1, fa1) (i2, fa2) =+    solveMatchLTerm sortOfSkol (i1 `matchWith` i2 <> fa1 `matchFact` fa2)+  where+    sortOfSkol (SkName  n) = sortOfName n+    sortOfSkol (SkConst v) = lvarSort v
+ src/Theory/Constraint/Solver/Types.hs view
@@ -0,0 +1,150 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell    #-}+{-# LANGUAGE TypeOperators      #-}+{-# LANGUAGE ViewPatterns       #-}+-- |+-- Copyright   : (c) 2010-2012 Benedikt Schmidt & Simon Meier+-- License     : GPL v3 (see LICENSE)+--+-- Maintainer  : Simon Meier <iridcode@gmail.com>+-- Portability : GHC only+--+-- Common types for our constraint solver. They must be declared jointly+-- because there is a recursive dependency between goals, proof contexts, and+-- case distinctions.+module Theory.Constraint.Solver.Types (++  -- * Proof context+    ProofContext(..)+  , InductionHint(..)++  , pcSignature+  , pcRules+  , pcUniqueFactInsts+  , pcCaseDists+  , pcCaseDistKind+  , pcUseInduction+  , pcTraceQuantifier+  , pcMaudeHandle++  -- ** Classified rules+  , ClassifiedRules(..)+  , emptyClassifiedRules+  , crConstruct+  , crDestruct+  , crProtocol+  , joinAllRules+  , nonSilentRules++  -- * Precomputed case distinctions.+  , CaseDistinction(..)++  , cdGoal+  , cdCases++  ) where++import           Prelude                  hiding (id, (.))++import           Data.Binary+import           Data.DeriveTH+import           Data.Label               hiding (get)+import qualified Data.Label               as L+import           Data.Monoid              (Monoid(..))+import qualified Data.Set                 as S++import           Control.Basics+import           Control.Category+import           Control.DeepSeq++import           Logic.Connectives+import           Theory.Constraint.System+import           Theory.Model+++----------------------------------------------------------------------+-- ClassifiedRules+----------------------------------------------------------------------++data ClassifiedRules = ClassifiedRules+     { _crProtocol      :: [RuleAC] -- all protocol rules+     , _crDestruct      :: [RuleAC] -- destruction rules+     , _crConstruct     :: [RuleAC] -- construction rules+     }+     deriving( Eq, Ord, Show )++$(mkLabels [''ClassifiedRules])++-- | The empty proof rule set.+emptyClassifiedRules :: ClassifiedRules+emptyClassifiedRules = ClassifiedRules [] [] []++-- | @joinAllRules rules@ computes the union of all rules classified in+-- @rules@.+joinAllRules :: ClassifiedRules -> [RuleAC]+joinAllRules (ClassifiedRules a b c) = a ++ b ++ c++-- | Extract all non-silent rules.+nonSilentRules :: ClassifiedRules -> [RuleAC]+nonSilentRules = filter (not . null . L.get rActs) . joinAllRules+++------------------------------------------------------------------------------+-- Proof Context+------------------------------------------------------------------------------++-- | A big-step case distinction.+data CaseDistinction = CaseDistinction+     { _cdGoal     :: Goal   -- start goal of case distinction+       -- disjunction of named sequents with premise being solved; each name+       -- being the path of proof steps required to arrive at these cases+     , _cdCases    :: Disj ([String], System)+     }+     deriving( Eq, Ord, Show )++data InductionHint = UseInduction | AvoidInduction+       deriving( Eq, Ord, Show )++-- | A proof context contains the globally fresh facts, classified rewrite+-- rules and the corresponding precomputed premise case distinction theorems.+data ProofContext = ProofContext+       { _pcSignature       :: SignatureWithMaude+       , _pcRules           :: ClassifiedRules+       , _pcUniqueFactInsts :: S.Set FactTag+       , _pcCaseDistKind    :: CaseDistKind+       , _pcCaseDists       :: [CaseDistinction]+       , _pcUseInduction    :: InductionHint+       , _pcTraceQuantifier :: SystemTraceQuantifier+       }+       deriving( Eq, Ord, Show )++$(mkLabels [''ProofContext, ''CaseDistinction])+++-- | The 'MaudeHandle' of a proof-context.+pcMaudeHandle :: ProofContext :-> MaudeHandle+pcMaudeHandle = sigmMaudeHandle . pcSignature++-- Instances+------------++instance HasFrees CaseDistinction where+    foldFrees f th =+        foldFrees f (L.get cdGoal th)   `mappend`+        foldFrees f (L.get cdCases th)++    mapFrees f th = CaseDistinction <$> mapFrees f (L.get cdGoal th)+                                    <*> mapFrees f (L.get cdCases th)+++-- NFData+---------++$( derive makeBinary ''CaseDistinction)+$( derive makeBinary ''ClassifiedRules)+$( derive makeBinary ''InductionHint)++$( derive makeNFData ''CaseDistinction)+$( derive makeNFData ''ClassifiedRules)+$( derive makeNFData ''InductionHint)
+ src/Theory/Constraint/System.hs view
@@ -0,0 +1,458 @@+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell    #-}+{-# LANGUAGE TypeOperators      #-}+{-# LANGUAGE ViewPatterns       #-}+-- |+-- Copyright   : (c) 2010-2012 Benedikt Schmidt & Simon Meier+-- License     : GPL v3 (see LICENSE)+--+-- Maintainer  : Simon Meier <iridcode@gmail.com>+-- Portability : GHC only+--+-- This is the public interface for constructing and deconstructing constraint+-- systems. The interface for performing constraint solving provided by+-- "Theory.Constraint.Solver".+module Theory.Constraint.System (+  -- * Constraints+    module Theory.Constraint.System.Constraints++  -- * Constraint systems+  , System++  -- ** Construction+  , emptySystem++  , SystemTraceQuantifier(..)+  , formulaToSystem++  -- ** Node constraints+  , sNodes+  , allKDConcs++  , nodeConcNode+  , nodePremNode+  , nodePremFact+  , nodeConcFact+  , resolveNodePremFact+  , resolveNodeConcFact++  -- ** Actions+  , allActions+  , allKUActions+  , unsolvedActionAtoms+  -- FIXME: The two functions below should also be prefixed with 'unsolved'+  , kuActionAtoms+  , standardActionAtoms++  -- ** Edge and chain constraints+  , sEdges+  , unsolvedChains++  -- ** Temporal ordering+  , sLessAtoms++  , rawLessRel+  , rawEdgeRel++  , alwaysBefore+  , isInTrace++  -- ** The last node+  , sLastAtom+  , isLast++  -- ** Equations+  , module Theory.Tools.EquationStore+  , sEqStore+  , sSubst+  , sConjDisjEqs++  -- ** Formulas+  , sFormulas+  , sSolvedFormulas++  -- ** Lemmas+  , sLemmas+  , insertLemma++  -- ** Keeping track of typing assumptions+  , CaseDistKind(..)+  , sCaseDistKind++  -- ** Goals+  , GoalStatus(..)+  , gsSolved+  , gsLoopBreaker+  , gsNr++  , sGoals+  , sNextGoalNr++  -- * Pretty-printing+  , prettySystem+  , prettyNonGraphSystem++  ) where++import           Prelude                              hiding (id, (.))++import           Data.Binary+import qualified Data.DAG.Simple                      as D+import           Data.DeriveTH+import qualified Data.Map                             as M+import           Data.Maybe                           (fromMaybe)+import           Data.Monoid                          (Monoid(..))+import qualified Data.Set                             as S++import           Control.Basics+import           Control.Category+import           Control.DeepSeq++import           Data.Label                           ((:->), mkLabels)+import qualified Extension.Data.Label                 as L++import           Logic.Connectives+import           Theory.Constraint.System.Constraints+import           Theory.Model+import           Theory.Text.Pretty+import           Theory.Tools.EquationStore++++------------------------------------------------------------------------------+-- Types+------------------------------------------------------------------------------++-- | Whether we are checking for the existence of a trace satisfiying a the+-- current constraint system or whether we're checking that no traces+-- satisfies the current constraint system.+data SystemTraceQuantifier = ExistsSomeTrace | ExistsNoTrace+       deriving( Eq, Ord, Show )++-- | Case dinstinction kind that are allowed. The order of the kinds+-- corresponds to the subkinding relation: untyped < typed.+data CaseDistKind = UntypedCaseDist | TypedCaseDist+       deriving( Eq, Ord )++instance Show CaseDistKind where+    show UntypedCaseDist = "untyped"+    show TypedCaseDist   = "typed"++-- | The status of a 'Goal'. Use its 'Semigroup' instance to combine the+-- status info of goals that collapse.+data GoalStatus = GoalStatus+    { _gsSolved :: Bool+       -- True if the goal has been solved already.+    , _gsNr :: Integer+       -- The number of the goal: we use it to track the creation order of+       -- goals.+    , _gsLoopBreaker :: Bool+       -- True if this goal should be solved with care because it may lead to+       -- non-termination.+    }+    deriving( Eq, Ord, Show )++-- | A constraint system.+data System = System+    { _sNodes          :: M.Map NodeId RuleACInst+    , _sEdges          :: S.Set Edge+    , _sLessAtoms      :: S.Set (NodeId, NodeId)+    , _sLastAtom       :: Maybe NodeId+    , _sEqStore        :: EqStore+    , _sFormulas       :: S.Set LNGuarded+    , _sSolvedFormulas :: S.Set LNGuarded+    , _sLemmas         :: S.Set LNGuarded+    , _sGoals          :: M.Map Goal GoalStatus+    , _sNextGoalNr     :: Integer+    , _sCaseDistKind   :: CaseDistKind+    }+    -- NOTE: Don't forget the update 'substSystem' in+    -- "Constraint.Solver.Reduction" when adding further fields to the+    -- constraint system.+    deriving( Eq, Ord )++$(mkLabels [''System, ''GoalStatus])+++-- Further accessors+--------------------++-- | Label to access the free substitution of the equation store.+sSubst :: System :-> LNSubst+sSubst = eqsSubst . sEqStore++-- | Label to access the conjunction of disjunctions of fresh substutitution in+-- the equation store.+sConjDisjEqs :: System :-> Conj (SplitId, S.Set (LNSubstVFresh))+sConjDisjEqs = eqsConj . sEqStore++++------------------------------------------------------------------------------+-- Constraint system construction+------------------------------------------------------------------------------++-- | The empty constraint system, which is logically equivalent to true.+emptySystem :: CaseDistKind -> System+emptySystem = System+    M.empty S.empty S.empty Nothing emptyEqStore+    S.empty S.empty S.empty+    M.empty 0++-- | Returns the constraint system that has to be proven to show that given+-- formula holds in the context of the given theory.+formulaToSystem :: CaseDistKind -> SystemTraceQuantifier -> LNFormula -> System+formulaToSystem kind traceQuantifier fm =+    L.set sFormulas (S.singleton gf) (emptySystem kind)+  where+    adapt = case traceQuantifier of+      ExistsSomeTrace -> id+      ExistsNoTrace   -> gnot+    gf = either error id (adapt <$> formulaToGuarded fm)++-- | Add a lemma / additional assumption to a constraint system.+insertLemma :: LNFormula -> System -> System+insertLemma fm =+    L.modify sLemmas (S.insert (either error id $ formulaToGuarded fm))+++------------------------------------------------------------------------------+-- Queries+------------------------------------------------------------------------------+++-- Nodes+------------++-- | A list of all KD-conclusions in the 'System'.+allKDConcs :: System -> [(NodeId, RuleACInst, LNTerm)]+allKDConcs sys = do+    (i, ru)                            <- M.toList $ L.get sNodes sys+    (_, kFactView -> Just (DnK, _, m)) <- enumConcs ru+    return (i, ru, m)++-- | @nodeRule v@ accesses the rule label of node @v@ under the assumption that+-- it is present in the sequent.+nodeRule :: NodeId -> System -> RuleACInst+nodeRule v se =+    fromMaybe errMsg $ M.lookup v $ L.get sNodes se+  where+    errMsg = error $+        "nodeRule: node '" ++ show v ++ "' does not exist in sequent\n" +++        render (nest 2 $ prettySystem se)+++-- | @nodePremFact prem se@ computes the fact associated to premise @prem@ in+-- sequent @se@ under the assumption that premise @prem@ is a a premise in+-- @se@.+nodePremFact :: NodePrem -> System -> LNFact+nodePremFact (v, i) se = L.get (rPrem i) $ nodeRule v se++-- | @nodePremNode prem@ is the node that this premise is referring to.+nodePremNode :: NodePrem -> NodeId+nodePremNode = fst++-- | All facts associated to this node premise.+resolveNodePremFact :: NodePrem -> System -> Maybe LNFact+resolveNodePremFact (v, i) se = lookupPrem i =<< M.lookup v (L.get sNodes se)++-- | The fact associated with this node conclusion, if there is one.+resolveNodeConcFact :: NodeConc -> System -> Maybe LNFact+resolveNodeConcFact (v, i) se = lookupConc i =<< M.lookup v (L.get sNodes se)++-- | @nodeConcFact (NodeConc (v, i))@ accesses the @i@-th conclusion of the+-- rule associated with node @v@ under the assumption that @v@ is labeled with+-- a rule that has an @i@-th conclusion.+nodeConcFact :: NodeConc -> System -> LNFact+nodeConcFact (v, i) = L.get (rConc i) . nodeRule v++-- | 'nodeConcNode' @c@ compute the node-id of the node conclusion @c@.+nodeConcNode :: NodeConc -> NodeId+nodeConcNode = fst+++-- Actions+----------++-- | All actions that hold in a sequent.+unsolvedActionAtoms :: System -> [(NodeId, LNFact)]+unsolvedActionAtoms sys =+      do (ActionG i fa, status) <- M.toList (L.get sGoals sys)+         guard (not $ L.get gsSolved status)+         return (i, fa)++-- | All actions that hold in a sequent.+allActions :: System -> [(NodeId, LNFact)]+allActions sys =+      unsolvedActionAtoms sys+  <|> do (i, ru) <- M.toList $ L.get sNodes sys+         (,) i <$> L.get rActs ru++-- | All actions that hold in a sequent.+allKUActions :: System -> [(NodeId, LNFact, LNTerm)]+allKUActions sys = do+    (i, fa@(kFactView -> Just (UpK, _, m))) <- allActions sys+    return (i, fa, m)++-- | The standard actions, i.e., non-KU-actions.+standardActionAtoms :: System -> [(NodeId, LNFact)]+standardActionAtoms = filter (not . isKUFact . snd) . unsolvedActionAtoms++-- | All KU-actions.+kuActionAtoms :: System -> [(NodeId, LNFact, LNTerm)]+kuActionAtoms sys = do+    (i, fa@(kFactView -> Just (UpK, _, m))) <- unsolvedActionAtoms sys+    return (i, fa, m)++-- Destruction chains+---------------------++-- | All unsolved destruction chains in the constraint system.+unsolvedChains :: System -> [(NodeConc, NodePrem)]+unsolvedChains sys = do+    (ChainG from to, status) <- M.toList $ L.get sGoals sys+    guard (not $ L.get gsSolved status)+    return (from, to)+++-- The temporal order+---------------------++-- | @(from,to)@ is in @rawEdgeRel se@ iff we can prove that there is an+-- edge-path from @from@ to @to@ in @se@ without appealing to transitivity.+rawEdgeRel :: System -> [(NodeId, NodeId)]+rawEdgeRel sys = map (nodeConcNode *** nodePremNode) $+     [(from, to) | Edge from to <- S.toList $ L.get sEdges sys]+  ++ unsolvedChains sys++-- | @(from,to)@ is in @rawLessRel se@ iff we can prove that there is a path+-- (possibly using the 'Less' relation) from @from@ to @to@ in @se@ without+-- appealing to transitivity.+rawLessRel :: System -> [(NodeId,NodeId)]+rawLessRel se = S.toList (L.get sLessAtoms se) ++ rawEdgeRel se++-- | Returns a predicate that is 'True' iff the first argument happens before+-- the second argument in all models of the sequent.+alwaysBefore :: System -> (NodeId -> NodeId -> Bool)+alwaysBefore sys =+    check -- lessRel is cached for partial applications+  where+    lessRel   = rawLessRel sys+    check i j =+         -- speed-up check by first checking less-atoms+         ((i, j) `S.member` L.get sLessAtoms sys)+      || (j `S.member` D.reachableSet [i] lessRel)++-- | 'True' iff the given node id is guaranteed to be instantiated to an+-- index in the trace.+isInTrace :: System -> NodeId -> Bool+isInTrace sys i =+     i `M.member` L.get sNodes sys+  || isLast sys i+  || any ((i ==) . fst) (unsolvedActionAtoms sys)++-- | 'True' iff the given node id is guaranteed to be instantiated to the last+-- index of the trace.+isLast :: System -> NodeId -> Bool+isLast sys i = Just i == L.get sLastAtom sys++++------------------------------------------------------------------------------+-- Pretty printing                                                          --+------------------------------------------------------------------------------++-- | Pretty print a sequent+prettySystem :: HighlightDocument d => System -> d+prettySystem se = vcat $+    map combine+      [ ("nodes",          vcat $ map prettyNode $ M.toList $ L.get sNodes se)+      , ("actions",        fsepList ppActionAtom $ unsolvedActionAtoms se)+      , ("edges",          fsepList prettyEdge   $ S.toList $ L.get sEdges se)+      , ("less",           fsepList prettyLess   $ S.toList $ L.get sLessAtoms se)+      , ("unsolved goals", prettyGoals False se)+      ]+    ++ [prettyNonGraphSystem se]+  where+    combine (header, d) = fsep [keyword_ header <> colon, nest 2 d]+    ppActionAtom (i, fa) = prettyNAtom (Action (varTerm i) fa)++-- | Pretty print the non-graph part of the sequent; i.e. equation store and+-- clauses.+prettyNonGraphSystem :: HighlightDocument d => System -> d+prettyNonGraphSystem se = vsep $ map combine+  [ ("last",            maybe (text "none") prettyNodeId $ L.get sLastAtom se)+  , ("allowed cases",   text $ show $ L.get sCaseDistKind se)+  , ("formulas",        vsep $ map prettyGuarded $ S.toList $ L.get sFormulas se)+  , ("equations",       prettyEqStore $ L.get sEqStore se)+  , ("solved formulas", vsep $ map prettyGuarded $ S.toList $ L.get sSolvedFormulas se)+  , ("lemmas",          vsep $ map prettyGuarded $ S.toList $ L.get sLemmas se)+  , ("solved goals",    prettyGoals True se)+  ]+  where+    combine (header, d)  = fsep [keyword_ header <> colon, nest 2 d]++-- | Pretty print solved or unsolved goals.+prettyGoals :: HighlightDocument d => Bool -> System -> d+prettyGoals solved sys = vsep $ do+    (goal, status) <- M.toList $ L.get sGoals sys+    guard (solved == L.get gsSolved status)+    let nr  = L.get gsNr status+        loopBreaker | L.get gsLoopBreaker status = " (loop breaker)"+                    | otherwise                  = ""+    return $ prettyGoal goal <-> lineComment_ ("nr: " ++ show nr ++ loopBreaker)+++-- Additional instances+-----------------------++deriving instance Show System++instance Apply CaseDistKind where+    apply = const id++instance HasFrees CaseDistKind where+    foldFrees = const mempty+    mapFrees  = const pure++instance HasFrees GoalStatus where+    foldFrees = const mempty+    mapFrees  = const pure++instance HasFrees System where+    foldFrees fun (System a b c d e f g h i j k) =+        foldFrees fun a `mappend`+        foldFrees fun b `mappend`+        foldFrees fun c `mappend`+        foldFrees fun d `mappend`+        foldFrees fun e `mappend`+        foldFrees fun f `mappend`+        foldFrees fun g `mappend`+        foldFrees fun h `mappend`+        foldFrees fun i `mappend`+        foldFrees fun j `mappend`+        foldFrees fun k++    mapFrees fun (System a b c d e f g h i j k) =+        System <$> mapFrees fun a+               <*> mapFrees fun b+               <*> mapFrees fun c+               <*> mapFrees fun d+               <*> mapFrees fun e+               <*> mapFrees fun f+               <*> mapFrees fun g+               <*> mapFrees fun h+               <*> mapFrees fun i+               <*> mapFrees fun j+               <*> mapFrees fun k+++$( derive makeBinary ''CaseDistKind)+$( derive makeBinary ''GoalStatus)+$( derive makeBinary ''System)+$( derive makeBinary ''SystemTraceQuantifier)++$( derive makeNFData ''CaseDistKind)+$( derive makeNFData ''GoalStatus)+$( derive makeNFData ''System)+$( derive makeNFData ''SystemTraceQuantifier)
+ src/Theory/Constraint/System/Constraints.hs view
@@ -0,0 +1,206 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE TemplateHaskell    #-}+-- |+-- Copyright   : (c) 2010-2012 Benedikt Schmidt & Simon Meier+-- License     : GPL v3 (see LICENSE)+--+-- Maintainer  : Simon Meier <iridcode@gmail.com>+-- Portability : GHC only+--+-- Types representing constraints.+module Theory.Constraint.System.Constraints (+  -- * Guarded formulas+    module Theory.Constraint.System.Guarded++  -- * Graph constraints+  , NodePrem+  , NodeConc+  , Edge(..)+  , Less++  -- * Goal constraints+  , Goal(..)+  , isActionGoal+  , isStandardActionGoal+  , isPremiseGoal+  , isChainGoal+  , isSplitGoal+  , isDisjGoal++  -- ** Pretty-printing+  , prettyNode+  , prettyNodePrem+  , prettyNodeConc+  , prettyEdge+  , prettyLess+  , prettyGoal+  ) where++import           Data.Binary+import           Data.DeriveTH+import           Data.Generics+import           Extension.Data.Monoid            (Monoid(..))++import           Control.Basics+import           Control.DeepSeq++import           Text.PrettyPrint.Class++import           Logic.Connectives+import           Theory.Constraint.System.Guarded+import           Theory.Model+import           Theory.Text.Pretty+import           Theory.Tools.EquationStore++------------------------------------------------------------------------------+-- Graph part of a sequent                                                  --+------------------------------------------------------------------------------++-- | A premise of a node.+type NodePrem = (NodeId, PremIdx)++-- | A conclusion of a node.+type NodeConc = (NodeId, ConcIdx)++-- | A labeled edge in a derivation graph.+data Edge = Edge {+      eSrc :: NodeConc+    , eTgt :: NodePrem+    }+  deriving (Show, Ord, Eq, Data, Typeable)++-- | A *⋖* constraint between 'NodeId's.+type Less = (NodeId, NodeId)++-- Instances+------------++instance Apply Edge where+    apply subst (Edge from to) = Edge (apply subst from) (apply subst to)++instance HasFrees Edge where+    foldFrees f (Edge x y) = foldFrees f x `mappend` foldFrees f y+    mapFrees  f (Edge x y) = Edge <$> mapFrees f x <*> mapFrees f y+++------------------------------------------------------------------------------+-- Goals+------------------------------------------------------------------------------++-- | A 'Goal' denotes that a constraint reduction rule is applicable, which+-- might result in case splits. We either use a heuristic to decide what goal+-- to solve next or leave the choice to user (in case of the interactive UI).+data Goal =+       ActionG LVar LNFact+       -- ^ An action that must exist in the trace.+     | ChainG NodeConc NodePrem+       -- A destruction chain.+     | PremiseG NodePrem LNFact+       -- ^ A premise that must have an incoming direct edge.+     | SplitG SplitId+       -- ^ A case split over equalities.+     | DisjG (Disj LNGuarded)+       -- ^ A case split over a disjunction.+     deriving( Eq, Ord, Show )++-- Indicators+-------------++isActionGoal :: Goal -> Bool+isActionGoal (ActionG _ _) = True+isActionGoal _             = False++isStandardActionGoal :: Goal -> Bool+isStandardActionGoal (ActionG _ fa) = not (isKUFact fa)+isStandardActionGoal _              = False++isPremiseGoal :: Goal -> Bool+isPremiseGoal (PremiseG _ _) = True+isPremiseGoal _              = False++isChainGoal :: Goal -> Bool+isChainGoal (ChainG _ _) = True+isChainGoal _            = False++isSplitGoal :: Goal -> Bool+isSplitGoal (SplitG _) = True+isSplitGoal _          = False++isDisjGoal :: Goal -> Bool+isDisjGoal (DisjG _) = True+isDisjGoal _         = False++++-- Instances+------------++instance HasFrees Goal where+    foldFrees f goal = case goal of+        ActionG i fa  -> foldFrees f i <> foldFrees f fa+        PremiseG p fa -> foldFrees f p <> foldFrees f fa+        ChainG c p    -> foldFrees f c <> foldFrees f p+        SplitG i      -> foldFrees f i+        DisjG x       -> foldFrees f x++    mapFrees f goal = case goal of+        ActionG i fa  -> ActionG  <$> mapFrees f i <*> mapFrees f fa+        PremiseG p fa -> PremiseG <$> mapFrees f p <*> mapFrees f fa+        ChainG c p    -> ChainG   <$> mapFrees f c <*> mapFrees f p+        SplitG i      -> SplitG   <$> mapFrees f i+        DisjG x       -> DisjG    <$> mapFrees f x++instance Apply Goal where+    apply subst goal = case goal of+        ActionG i fa  -> ActionG  (apply subst i) (apply subst fa)+        PremiseG p fa -> PremiseG (apply subst p) (apply subst fa)+        ChainG c p    -> ChainG   (apply subst c) (apply subst p)+        SplitG i      -> SplitG   (apply subst i)+        DisjG x       -> DisjG    (apply subst x)+++------------------------------------------------------------------------------+-- Pretty printing                                                          --+------------------------------------------------------------------------------++-- | Pretty print a node.+prettyNode :: HighlightDocument d => (NodeId, RuleACInst) -> d+prettyNode (v,ru) = prettyNodeId v <> colon <-> prettyRuleACInst ru++-- | Pretty print a node conclusion.+prettyNodeConc :: HighlightDocument d => NodeConc -> d+prettyNodeConc (v, ConcIdx i) = parens (prettyNodeId v <> comma <-> int i)++-- | Pretty print a node premise.+prettyNodePrem :: HighlightDocument d => NodePrem -> d+prettyNodePrem (v, PremIdx i) = parens (prettyNodeId v <> comma <-> int i)++-- | Pretty print a edge as @src >-i--j-> tgt@.+prettyEdge :: HighlightDocument d => Edge -> d+prettyEdge (Edge c p) =+    prettyNodeConc c <-> operator_ ">-->" <-> prettyNodePrem p++-- | Pretty print a less-atom as @src < tgt@.+prettyLess :: HighlightDocument d => Less -> d+prettyLess (i, j) = prettyNAtom $ Less (varTerm i) (varTerm j)++-- | Pretty print a goal.+prettyGoal :: HighlightDocument d => Goal -> d+prettyGoal (ActionG i fa) = prettyNAtom (Action (varTerm i) fa)+prettyGoal (ChainG c p)   =+    prettyNodeConc c <-> operator_ "~~>" <-> prettyNodePrem p+prettyGoal (PremiseG p fa) =+    prettyNodePrem p <> brackets (prettyLNFact fa)+prettyGoal (DisjG (Disj gfs)) = (text "Disj" <>) $ fsep $+    punctuate (operator_ " |") (map (nest 1 . parens . prettyGuarded) gfs)+prettyGoal (SplitG x) =+    text "splitEqs" <> parens (text $ show (unSplitId x))++-- Derived instances+--------------------++$( derive makeBinary ''Edge)+$( derive makeBinary ''Goal)++$( derive makeNFData ''Edge)+$( derive makeNFData ''Goal)
+ src/Theory/Constraint/System/Dot.hs view
@@ -0,0 +1,522 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeOperators   #-}+-- |+-- Copyright   : (c) 2010, 2011 Simon Meier+-- License     : GPL v3 (see LICENSE)+--+-- Maintainer  : Simon Meier <iridcode@gmail.com>+-- Portability : GHC only+--+-- Conversion of the graph part of a sequent to a Graphviz Dot file.+module Theory.Constraint.System.Dot (+    dotSystemLoose+  , dotSystemCompact+  , compressSystem+  , BoringNodeStyle(..)+  ) where++import           Data.Char                (isSpace)+import           Data.Color+import qualified Data.DAG.Simple          as D+import qualified Data.Foldable            as F+import           Data.List+import qualified Data.Map                 as M+import           Data.Maybe+import           Data.Monoid              (Any(..))+import qualified Data.Set                 as S+import           Safe++import           Extension.Data.Label+import           Extension.Prelude++import           Control.Basics+import           Control.Monad.Reader+import           Control.Monad.State      (StateT, evalStateT)++import qualified Text.Dot                 as D+import           Text.PrettyPrint.Class++import           Theory.Constraint.System+import           Theory.Model+import           Theory.Text.Pretty       (opAction)++type NodeColorMap = M.Map (RuleInfo ProtoRuleACInstInfo IntrRuleACInfo) (HSV Double)+type SeDot = ReaderT (System, NodeColorMap) (StateT DotState D.Dot)++-- | State to avoid multiple drawing of the same entity.+data DotState = DotState {+    _dsNodes   :: M.Map NodeId   D.NodeId+  , _dsPrems   :: M.Map NodePrem D.NodeId+  , _dsConcs   :: M.Map NodeConc D.NodeId+  , _dsSingles :: M.Map (NodeConc, NodePrem) D.NodeId+  }++$(mkLabels [''DotState])++-- | Lift a 'D.Dot' action.+liftDot :: D.Dot a -> SeDot a+liftDot = lift . lift++-- | All edges in a bipartite graph that have neither start point nor endpoint+-- in common with any other edge.+singleEdges :: (Ord a, Ord b) => [(a,b)] -> [(a,b)]+singleEdges es =+    singles fst es `intersect` singles snd es+  where+    singles proj = concatMap single . groupOn proj . sortOn proj+    single []  = error "impossible"+    single [x] = return x+    single _   = mzero++-- | Get a lighter color.+lighter :: HSV Double -> RGB Double+lighter = hsvToRGB -- fmap (\c -> 1 - 0.3*(1-c)) . hsvToRGB++-- | Ensure that a 'SeDot' action is only executed once by querying and+-- updating the 'DotState' accordingly.+dotOnce :: Ord k+        => (DotState :-> M.Map k D.NodeId) -- ^ Accessor to map storing this type of actions.+        -> k                               -- ^ Action index.+        -> SeDot D.NodeId                  -- ^ Action to execute only once.+        -> SeDot D.NodeId+dotOnce mapL k dot = do+    i <- join $ (maybe dot return . M.lookup k) `liftM` getM mapL+    modM mapL (M.insert k i)+    return i++dotNode :: NodeId -> SeDot D.NodeId+dotNode v = dotOnce dsNodes v $ do+    (se, colorMap) <- ask+    let nodes = get sNodes se+        dot info moreStyle facts = do+            vId <- liftDot $ D.node $ [("label", show v ++ info),("shape","ellipse")]+                                      ++ moreStyle+            _ <- facts vId+            return vId++    case M.lookup v nodes of+      Nothing -> do+          dot "" [] (const $ return ()) -- \vId -> do+              {-+              premIds <- mapM dotPrem+                           [ NodePremFact v fa+                           | SeRequires v' fa <- S.toList $ get sRequires se+                           , v == v' ]+              sequence_ [ dotIntraRuleEdge premId vId | premId <- premIds ]+              -}+      Just ru -> do+          let+              color     = M.lookup (get rInfo ru) colorMap+              nodeColor = maybe "white" (rgbToHex . lighter) color+          dot (label ru) [("fillcolor", nodeColor),("style","filled")] $ \vId -> do+              premIds <- mapM dotPrem+                           [ (v,i) | (i,_) <- enumPrems ru ]+              concIds <- mapM dotConc+                           [ (v,i) | (i,_) <- enumConcs ru ]+              sequence_ [ dotIntraRuleEdge premId vId | premId <- premIds ]+              sequence_ [ dotIntraRuleEdge vId concId | concId <- concIds ]+  where+    label ru = " : " ++ render nameAndActs+      where+        nameAndActs =+            ruleInfo (prettyProtoRuleName . get praciName) prettyIntrRuleACInfo (get rInfo ru) <->+            brackets (vcat $ punctuate comma $ map prettyLNFact $ get rActs ru)++-- | An edge from a rule node to its premises or conclusions.+dotIntraRuleEdge :: D.NodeId -> D.NodeId -> SeDot ()+dotIntraRuleEdge from to = liftDot $ D.edge from to [("color","gray")]++{-+-- | An edge from a rule node to some of its premises or conclusions.+dotNonFixedIntraRuleEdge :: D.NodeId -> D.NodeId -> SeDot ()+dotNonFixedIntraRuleEdge from to =+    liftDot $ D.edge from to [("color","steelblue")]+-}++-- | The style of a node displaying a fact.+factNodeStyle :: LNFact -> [(String,String)]+factNodeStyle fa+  | isJust (kFactView fa) = []+  | otherwise             = [("fillcolor","gray85"),("style","filled")]++-- | An edge that shares no endpoints with another edge and is therefore+-- contracted.+--+-- FIXME: There may be too many edges being contracted.+dotSingleEdge :: (NodeConc, NodePrem) -> SeDot D.NodeId+dotSingleEdge edge@(_, to) = dotOnce dsSingles edge $ do+    se <- asks fst+    let fa    = nodePremFact to se+        label = render $ prettyLNFact fa+    liftDot $ D.node $ [("label", label),("shape", "hexagon")]+                       ++ factNodeStyle fa++-- | A compressed edge.+dotTrySingleEdge :: Eq c+                 => ((NodeConc, NodePrem) -> c) -> c+                 -> SeDot D.NodeId -> SeDot D.NodeId+dotTrySingleEdge sel x dot = do+    singles <- getM dsSingles+    maybe dot (return . snd) $ find ((x ==) . sel . fst) $ M.toList singles++-- | Premises.+dotPrem :: NodePrem -> SeDot D.NodeId+dotPrem prem@(v, i) =+    dotOnce dsPrems prem $ dotTrySingleEdge snd prem $ do+        nodes <- asks (get sNodes . fst)+        let ppPrem = show prem -- FIXME: Use better pretty printing here+            (label, moreStyle) = fromMaybe (ppPrem, []) $ do+                ru <- M.lookup v nodes+                fa <- lookupPrem i ru+                return ( render $ prettyLNFact fa+                       , factNodeStyle fa+                       )+        liftDot $ D.node $ [("label", label),("shape",shape)]+                           ++ moreStyle+  where+    shape = "invtrapezium"++-- | Conclusions.+dotConc :: NodeConc -> SeDot D.NodeId+dotConc =+    dotNodeWithIndex dsConcs fst rConcs (id *** getConcIdx) "trapezium"+  where+    dotNodeWithIndex stateSel edgeSel ruleSel unwrap shape x0 =+        dotOnce stateSel x0 $ dotTrySingleEdge edgeSel x0 $ do+            let x = unwrap x0+            nodes <- asks (get sNodes . fst)+            let (label, moreStyle) = fromMaybe (show x, []) $ do+                    ru <- M.lookup (fst x) nodes+                    fa <- (`atMay` snd x) $ get ruleSel ru+                    return ( render $ prettyLNFact fa+                           , factNodeStyle fa+                           )+            liftDot $ D.node $ [("label", label),("shape",shape)]+                               ++ moreStyle++-- | Convert the sequent to a 'D.Dot' action representing this sequent as a+-- graph in the GraphViz format. The style is loose in the sense that each+-- premise and conclusion gets its own node.+dotSystemLoose :: System -> D.Dot ()+dotSystemLoose se =+    (`evalStateT` DotState M.empty M.empty M.empty M.empty) $+    (`runReaderT` (se, nodeColorMap (M.elems $ get sNodes se))) $ do+        liftDot $ setDefaultAttributes+        -- draw single edges with matching facts.+        mapM_ dotSingleEdge $ singleEdges $ do+            Edge from to <- S.toList $ get sEdges se+            -- FIXME: ensure that conclusion and premise are equal+            guard (nodeConcFact from se == nodePremFact to se)+            return (from, to)+        sequence_ $ do+            (v, ru) <- M.toList $ get sNodes se+            (i, _)  <- enumConcs ru+            return (dotConc (v, i))+        sequence_ $ do+            (v, ru) <- M.toList $ get sNodes se+            (i, _)  <- enumPrems ru+            return (dotPrem (v,i))+        mapM_ dotNode     $ M.keys   $ get sNodes     se+        mapM_ dotEdge     $ S.toList $ get sEdges     se+        mapM_ dotChain    $            unsolvedChains se+        mapM_ dotLess     $ S.toList $ get sLessAtoms se+  where+    dotEdge  (Edge src tgt)  = do+        mayNid <- M.lookup (src,tgt) `liftM` getM dsSingles+        maybe (dotGenEdge [] src tgt) (const $ return ()) mayNid++    dotChain (src, tgt) =+        dotGenEdge [("style","dashed"),("color","green")] src tgt++    dotLess (src, tgt) = do+        srcId <- dotNode src+        tgtId <- dotNode tgt+        liftDot $ D.edge srcId tgtId+            [("color","black"),("style","dotted")] -- FIXME: Reactivate,("constraint","false")]+            -- setting constraint to false ignores less-edges when ranking nodes.++    dotGenEdge style src tgt = do+        srcId <- dotConc src+        tgtId <- dotPrem tgt+        liftDot $ D.edge srcId tgtId style++    {-+    dotProvides (SeProvides v fa) = do+        vId <- dotNode v+        faId <- liftDot $ D.node [("label",label),("shape","trapezium")]+        dotNonFixedIntraRuleEdge vId faId+      where+        label = render $ prettyLNFact fa++    dotRequires (SeRequires v _fa) = do+       _vId <- dotNode v+       return ()+       -- FIXME: Reenable+       -- premId <- dotPrem (NodePremFact v fa)+       -- dotNonFixedIntraRuleEdge premId vId+    -}++-- | Set default attributes for nodes and edges.+setDefaultAttributes :: D.Dot ()+setDefaultAttributes = do+  D.attribute ("nodesep","0.3")+  D.attribute ("ranksep","0.3")+  D.nodeAttributes [("fontsize","8"),("fontname","Helvetica"),("width","0.3"),("height","0.2")]+  D.edgeAttributes [("fontsize","8"),("fontname","Helvetica")]+++-- | Compute a color map for nodes labelled with a proof rule info of one of+-- the given rules.+nodeColorMap :: [RuleACInst] -> NodeColorMap+nodeColorMap rules =+    M.fromList $+      [ (get rInfo ru, getColor (gIdx, mIdx))+      | (gIdx, grp) <- groups, (mIdx, ru) <- zip [0..] grp ]+  where+    groupIdx ru | isDestrRule ru                   = 0+                | isConstrRule ru                  = 2+                | isFreshRule ru || isISendRule ru = 3+                | otherwise                        = 1++    -- groups of rules labeled with their index in the group+    groups = [ (gIdx, [ ru | ru <- rules, gIdx == groupIdx ru])+             | gIdx <- [0..3]+             ]++    -- color for each member of a group+    colors = M.fromList $ lightColorGroups intruderHue (map (length . snd) groups)+    getColor idx = fromMaybe (HSV 0 1 1) $ M.lookup idx colors++    -- The hue of the intruder rules+    intruderHue :: Double+    intruderHue = 18 / 360++------------------------------------------------------------------------------+-- Record based dotting+------------------------------------------------------------------------------++-- | The style for nodes of the intruder.+data BoringNodeStyle = FullBoringNodes | CompactBoringNodes+    deriving( Eq, Ord, Show )+++-- | Dot a node in record based (compact) format.+dotNodeCompact :: BoringNodeStyle -> NodeId -> SeDot D.NodeId+dotNodeCompact boringStyle v = dotOnce dsNodes v $ do+    (se, colorMap) <- ask+    let hasOutgoingEdge =+            or [ v == v' | Edge (v', _) _ <- S.toList $ get sEdges se ]+    case M.lookup v $ get sNodes se of+      Nothing -> case filter ((v ==) . fst) (unsolvedActionAtoms se) of+        [] -> mkSimpleNode (show v) []+        as -> let lbl = (fsep $ punctuate comma $ map (prettyLNFact . snd) as)+                        <-> opAction <-> text (show v)+                  attrs | any (isKUFact . snd) as = [("color","gray")]+                        | otherwise               = [("color","darkblue")]+              in mkSimpleNode (render lbl) attrs+      Just ru -> do+          let color     = M.lookup (get rInfo ru) colorMap+              nodeColor = maybe "white" (rgbToHex . lighter) color+              attrs     = [("fillcolor", nodeColor),("style","filled")]+          ids <- mkNode ru attrs hasOutgoingEdge+          let prems = [ ((v, i), nid) | (Just (Left i),  nid) <- ids ]+              concs = [ ((v, i), nid) | (Just (Right i), nid) <- ids ]+          modM dsPrems $ M.union $ M.fromList prems+          modM dsConcs $ M.union $ M.fromList concs+          return $ fromJust $ lookup Nothing ids+  where++    mkSimpleNode lbl attrs =+        liftDot $ D.node $ [("label", lbl),("shape","ellipse")] ++ attrs++    mkNode ru attrs hasOutgoingEdge+      -- single node, share node-id for all premises and conclusions+      | boringStyle == CompactBoringNodes &&+        (isIntruderRule ru || isFreshRule ru) = do+            let lbl | hasOutgoingEdge = show v ++ " : " ++ showRuleCaseName ru+                    | otherwise       = concatMap snd as+            nid <- mkSimpleNode lbl []+            return [ (key, nid) | (key, _) <- ps ++ as ++ cs ]+      -- full record syntax+      | otherwise =+            fmap snd $ liftDot $ (`D.record` attrs) $+            D.vcat $ map D.hcat $ map (map (uncurry D.portField)) $+            filter (not . null) [ps, as, cs]+      where+        ps = renderRow [ (Just (Left i),  prettyLNFact p) | (i, p) <- enumPrems ru ]+        as = renderRow [ (Nothing,        ruleLabel ) ]+        cs = renderRow [ (Just (Right i), prettyLNFact c) | (i, c) <- enumConcs ru ]++        ruleLabel =+            prettyNodeId v <-> colon <-> text (showRuleCaseName ru) <>+            (brackets $ vcat $ punctuate comma $ map prettyLNFact $ get rActs ru)++        renderRow annDocs =+          zipWith (\(ann, _) lbl -> (ann, lbl)) annDocs $+            -- magic factor 1.3 compensates for space gained due to+            -- non-propertional font+            renderBalanced 100 (max 30 . round . (* 1.3)) (map snd annDocs)++        renderBalanced :: Double           -- ^ Total available width+                       -> (Double -> Int)  -- ^ Convert available space to actual line-width.+                       -> [Doc]            -- ^ Initial documents+                       -> [String]         -- ^ Rendered documents+        renderBalanced _          _    []   = []+        renderBalanced totalWidth conv docs =+            zipWith (\w d -> widthRender (conv (ratio * w)) d) usedWidths docs+          where+            oneLineRender  = renderStyle (defaultStyle { mode = OneLineMode })+            widthRender w  = scaleIndent . renderStyle (defaultStyle { lineLength = w })+            usedWidths     = map (fromIntegral . length . oneLineRender) docs+            ratio          = totalWidth / sum usedWidths+            scaleIndent line = case span isSpace line of+              (spaces, rest) ->+                  -- spaces are not wide-enough by default => scale them up+                  let n = (1.5::Double) * fromIntegral (length spaces)+                  in  replicate (round n) ' ' ++ rest++++-- | Dot a sequent in compact form (one record per rule)+dotSystemCompact :: BoringNodeStyle -> System -> D.Dot ()+dotSystemCompact boringStyle se =+    (`evalStateT` DotState M.empty M.empty M.empty M.empty) $+    (`runReaderT` (se, nodeColorMap (M.elems $ get sNodes se))) $ do+        liftDot $ setDefaultAttributes+        mapM_ (dotNodeCompact boringStyle) $ M.keys $ get sNodes       se+        mapM_ (dotNodeCompact boringStyle . fst) $ unsolvedActionAtoms se+        F.mapM_ dotEdge                            $ get sEdges        se+        F.mapM_ dotChain                           $ unsolvedChains    se+        F.mapM_ dotLess                            $ get sLessAtoms    se+  where+    missingNode shape label = liftDot $ D.node $ [("label", render label),("shape",shape)]+    dotPremC prem = dotOnce dsPrems prem $ missingNode "invtrapezium" $ prettyNodePrem prem+    dotConcC conc = dotOnce dsConcs conc $ missingNode "trapezium" $ prettyNodeConc conc+    dotEdge (Edge src tgt)  = do+        let check p = maybe False p (resolveNodePremFact tgt se) ||+                      maybe False p (resolveNodeConcFact src se)+            attrs | check isProtoFact =+                      [("style","bold"),("weight","10.0")] +++                      (guard (check isPersistentFact) >> [("color","gray50")])+                  | check isKFact     = [("color","orangered2")]+                  | otherwise         = [("color","gray30")]+        dotGenEdge attrs src tgt++    dotGenEdge style src tgt = do+        srcId <- dotConcC src+        tgtId <- dotPremC tgt+        liftDot $ D.edge srcId tgtId style++    dotChain (src, tgt) =+        dotGenEdge [("style","dashed"),("color","green")] src tgt++    dotLess (src, tgt) = do+        srcId <- dotNodeCompact boringStyle src+        tgtId <- dotNodeCompact boringStyle tgt+        liftDot $ D.edge srcId tgtId+            [("color","black"),("style","dotted")] -- FIXME: reactivate ,("constraint","false")]+            -- setting constraint to false ignores less-edges when ranking nodes.+++------------------------------------------------------------------------------+-- Compressed versions of a sequent+------------------------------------------------------------------------------++-- | Drop 'Less' atoms entailed by the edges of the 'System'.+dropEntailedOrdConstraints :: System -> System+dropEntailedOrdConstraints se =+    modify sLessAtoms (S.filter (not . entailed)) se+  where+    edges               = rawEdgeRel se+    entailed (from, to) = to `S.member` D.reachableSet [from] edges++-- | Unsound compression of the sequent that drops fully connected learns and+-- knows nodes.+compressSystem :: System -> System+compressSystem se0 =+    foldl' (flip tryHideNodeId) se (frees (get sLessAtoms se, get sNodes se))+  where+    se = dropEntailedOrdConstraints se0++-- | @hideTransferNode v se@ hides node @v@ in sequent @se@ if it is a+-- transfer node; i.e., a node annotated with a rule that is one of the+-- special intruder rules or a rule with with at most one premise and+-- at most one conclusion and both premises and conclusions have incoming+-- respectively outgoing edges.+--+-- The compression is chosen such that unly uninteresting nodes are that have+-- no open goal are suppressed.+tryHideNodeId :: NodeId -> System -> System+tryHideNodeId v se = fromMaybe se $ do+    guard $  (lvarSort v == LSortNode)+          && notOccursIn unsolvedChains+          && notOccursIn (get sFormulas)+    maybe hideAction hideRule (M.lookup v $ get sNodes se)+  where+    selectPart :: (System :-> S.Set a) -> (a -> Bool) -> [a]+    selectPart l p = filter p $ S.toList $ get l se++    notOccursIn :: HasFrees a => (System -> a) -> Bool+    notOccursIn proj = not $ getAny $ foldFrees (Any . (v ==)) $ proj se++    -- hide KU-actions deducing pairs, inverses, and simple terms+    hideAction = do+        guard $  not (null kuActions)+              && all eligibleTerm kuActions+              && all (\(i, j) -> not (i == j)) lNews+              && notOccursIn (standardActionAtoms)+              && notOccursIn (get sLastAtom)+              && notOccursIn (get sEdges)++        return $ modify sLessAtoms ( (`S.union` S.fromList lNews)+                                   . (`S.difference` S.fromList lIns)+                                   . (`S.difference` S.fromList lOuts)+                                   )+               $ modify sGoals (\m -> foldl' removeAction m kuActions)+               $ se+      where+        kuActions            = [ x | x@(i,_,_) <- kuActionAtoms se, i == v ]+        eligibleTerm (_,_,m) =+            isPair m || isInverse m || sortOfLNTerm m == LSortPub++        removeAction m (i, fa, _) = M.delete (ActionG i fa) m++        lIns  = selectPart sLessAtoms ((v ==) . snd)+        lOuts = selectPart sLessAtoms ((v ==) . fst)+        lNews = [ (i, j) | (i, _) <- lIns, (_, j) <- lOuts ]++    -- hide a rule, if it is not "too complicated"+    hideRule ru = do+        guard $  eligibleRule+              && ( length eIns  == length (get rPrems ru) )+              && ( length eOuts == length (get rConcs ru) )+              && ( all (not . selfEdge) eNews             )+              && notOccursIn (get sLastAtom)+              && notOccursIn (get sLessAtoms)+              && notOccursIn (unsolvedActionAtoms)++        return $ modify sEdges ( (`S.union` S.fromList eNews)+                               . (`S.difference` S.fromList eIns)+                               . (`S.difference` S.fromList eOuts)+                               )+               $ modify sNodes (M.delete v)+               $ se+      where+        eIns  = selectPart sEdges ((v ==) . nodePremNode . eTgt)+        eOuts = selectPart sEdges ((v ==) . nodeConcNode . eSrc)+        eNews = [ Edge cIn pOut | Edge cIn _ <- eIns, Edge _ pOut <- eOuts ]++        selfEdge (Edge cIn pOut) = nodeConcNode cIn == nodePremNode pOut++        eligibleRule =+             any ($ ru) [isISendRule, isIRecvRule, isCoerceRule, isFreshRule]+          || ( null (get rActs ru) &&+               all (\l -> length (get l ru) <= 1) [rPrems, rConcs]+             )++{-+-- | Try to hide a 'NodeId'. This only works if it has only action and either+-- edge or less constraints associated.+tryHideNodeId :: NodeId -> System -> System+-}+
+ src/Theory/Constraint/System/Guarded.hs view
@@ -0,0 +1,594 @@+{-# LANGUAGE BangPatterns         #-}+{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE TemplateHaskell      #-}+{-# LANGUAGE TypeSynonymInstances #-}+-- |+-- Copyright   : (c) 2011 Benedikt Schmidt & Simon Meier+-- License     : GPL v3 (see LICENSE)+--+-- Maintainer  : Benedikt Schmidt <beschmi@gmail.com>+-- Portability : GHC only+--+-- Guarded formulas.+module Theory.Constraint.System.Guarded (++  -- * Guarded formulas+    Guarded(..)+  , LGuarded+  , LNGuarded++  -- ** Smart constructors+  , gfalse+  , gtrue+  , gdisj+  , gconj+  , gex+  , gall+  , gnot+  , ginduct++  , formulaToGuarded++  -- ** Transformation+  , simplifyGuarded++  , mapGuardedAtoms++  -- ** Queries+  , isConjunction+  , isDisjunction+  , isAllGuarded+  , isExGuarded++  -- ** Conversions to non-bound representations+  , bvarToLVar+  , openGuarded++  -- ** Substitutions+  , substBound+  , substBoundAtom+  , substFree+  , substFreeAtom++  -- ** Pretty-printing+  , prettyGuarded++  ) where++import           Control.Applicative+import           Control.DeepSeq+import           Control.Monad.Error++import           Debug.Trace++import           Data.Binary+import           Data.DeriveTH+import           Data.Either                (partitionEithers)+import           Data.Foldable              (Foldable(..), foldMap)+import           Data.List+import           Data.Monoid                (mappend, mconcat)+import           Data.Traversable           hiding (mapM, sequence)++import           Logic.Connectives++import           Text.PrettyPrint.Highlight++import           Control.Arrow+import           Control.Monad.Fresh        hiding (mapM)++import           Theory.Model+++------------------------------------------------------------------------------+-- Types+------------------------------------------------------------------------------++data Guarded s c v = GAto  (Atom (VTerm c (BVar v)))+                   | GDisj (Disj (Guarded s c v))+                   | GConj (Conj (Guarded s c v))+                   | GGuarded Quantifier [s] [Atom (VTerm c (BVar v))] (Guarded s c v)+                    -- ^ Denotes @ALL xs. as => gf@ or @Ex xs. as & gf&+                    -- depending on the 'Quantifier'.+                    -- We assume that all bound variables xs occur in+                    -- f@i atoms in as.+                   deriving (Eq, Ord, Show)++isConjunction :: Guarded t t1 t2 -> Bool+isConjunction (GConj _)  = True+isConjunction _          = False++isDisjunction :: Guarded t t1 t2 -> Bool+isDisjunction (GDisj _)  = True+isDisjunction _          = False++isExGuarded :: Guarded t t1 t2 -> Bool+isExGuarded (GGuarded Ex _ _ _) = True+isExGuarded _                   = False++isAllGuarded :: Guarded t t1 t2 -> Bool+isAllGuarded (GGuarded All _ _ _) = True+isAllGuarded _                    = False++------------------------------------------------------------------------------+-- Folding+------------------------------------------------------------------------------++-- | Fold a guarded formula.+foldGuarded :: (Atom (VTerm c (BVar v)) -> b)+            -> (Disj b -> b)+            -> (Conj b -> b)+            -> (Quantifier -> [s] -> [Atom (VTerm c (BVar v))] -> b -> b)+            -> Guarded s c v+            -> b+foldGuarded fAto fDisj fConj fGuarded =+  go+ where+  go (GAto a)                = fAto a+  go (GDisj disj)            = fDisj $ fmap go disj+  go (GConj conj)            = fConj $ fmap go conj+  go (GGuarded qua ss as gf) = fGuarded qua ss as (go gf)++-- | Fold a guarded formula with scope info.+-- The Integer argument denotes the number of+-- quantifiers that have been encountered so far.+foldGuardedScope :: (Integer -> Atom (VTerm c (BVar v)) -> b)+                 -> (Disj b -> b)+                 -> (Conj b -> b)+                 -> (Quantifier -> [s] -> Integer -> [Atom (VTerm c (BVar v))] -> b -> b)+                 -> Guarded s c v+                 -> b+foldGuardedScope fAto fDisj fConj fGuarded =+  go 0+ where+  go !i (GAto a)            = fAto i a+  go !i (GDisj disj)        = fDisj $ fmap (go i) disj+  go !i (GConj conj)        = fConj $ fmap (go i) conj+  go !i (GGuarded qua ss as gf) =+    fGuarded qua ss i' as (go i' gf)+   where+    i' = i + fromIntegral (length ss)+++-- | Map a guarded formula with scope info.+-- The Integer argument denotes the number of+-- quantifiers that have been encountered so far.+mapGuardedAtoms :: (Integer -> Atom (VTerm c (BVar v))+                -> Atom (VTerm d (BVar w)))+                -> Guarded s c v+                -> Guarded s d w+mapGuardedAtoms f =+    foldGuardedScope (\i a -> GAto $ f i a) GDisj GConj+                     (\qua ss i as gf -> GGuarded qua ss (map (f i) as) gf)++------------------------------------------------------------------------------+-- Instances+------------------------------------------------------------------------------++{-+instance Functor (Guarded s c) where+    fmap f = foldGuarded (GAto . fmap (fmapTerm (fmap (fmap f)))) GDisj GConj+                         (\qua ss as gf -> GGuarded qua ss (map (fmap (fmapTerm (fmap (fmap f)))) as) gf)+-}++instance Foldable (Guarded s c) where+    foldMap f = foldGuarded (foldMap (foldMap (foldMap (foldMap f))))+                            (mconcat . getDisj)+                            (mconcat . getConj)+                            (\_qua _ss as b -> foldMap (foldMap (foldMap (foldMap (foldMap f)))) as `mappend` b)++traverseGuarded :: (Applicative f, Ord c, Ord v, Ord a)+                => (a -> f v) -> Guarded s c a -> f (Guarded s c v)+traverseGuarded f = foldGuarded (liftA GAto . traverse (traverseTerm (traverse (traverse f))))+                                (liftA GDisj . sequenceA)+                                (liftA GConj . sequenceA)+                                (\qua ss as gf -> GGuarded qua ss <$> traverse (traverse (traverseTerm (traverse (traverse f)))) as <*> gf)++instance Ord c => HasFrees (Guarded (String, LSort) c LVar) where+    foldFrees f = foldMap  (foldFrees f)+    mapFrees  f = traverseGuarded (mapFrees f)+++-- FIXME: remove name hints for variables for saturation?+type LGuarded c = Guarded (String, LSort) c LVar++------------------------------------------------------------------------------+-- Substitutions of bound for free and vice versa+------------------------------------------------------------------------------++-- | @substBoundAtom s a@ substitutes each occurence of a bound variables @i@+-- in @dom(s)@ with the corresponding free variable @x=s(i)@ in the atom @a@.+substBoundAtom :: Ord c => [(Integer,LVar)] -> Atom (VTerm c (BVar LVar)) -> Atom (VTerm c (BVar LVar))+substBoundAtom s = fmap (fmapTerm (fmap subst))+ where subst bv@(Bound i') = case lookup i' s of+                               Just x -> Free x+                               Nothing -> bv+       subst fv            = fv++-- | @substBound s gf@ substitutes each occurence of a bound+-- variable @i@ in @dom(s)@ with the corresponding free variable+-- @s(i)=x@ in all atoms in @gf@.+substBound :: Ord c => [(Integer,LVar)] -> LGuarded c -> LGuarded c+substBound s = mapGuardedAtoms (\j a -> substBoundAtom [(i+j,v) | (i,v) <- s] a)+++-- | @substFreeAtom s a@ substitutes each occurence of a free variables @v@+-- in @dom(s)@ with the bound variables @i=s(v)@ in the atom @a@.+substFreeAtom :: Ord c+              => [(LVar,Integer)]+              -> Atom (VTerm c (BVar LVar)) -> Atom (VTerm c (BVar LVar))+substFreeAtom s = fmap (fmapTerm (fmap subst))+ where subst fv@(Free x) = case lookup x s of+                               Just i -> Bound i+                               Nothing -> fv+       subst bv          = bv++-- | @substFreeAtom s gf@ substitutes each occurence of a free variables+-- @v in dom(s)@ with the correpsonding bound variables @i=s(v)@+-- in all atoms in  @gf@.+substFree :: Ord c => [(LVar,Integer)] -> LGuarded c -> LGuarded c+substFree s = mapGuardedAtoms (\j a -> substFreeAtom [(v,i+j) | (v,i) <- s] a)++-- | Assuming that there are no more bound variables left in an atom of a+-- formula, convert it to an atom with free variables only.+bvarToLVar :: Ord c => Atom (VTerm c (BVar LVar)) -> Atom (VTerm c LVar)+bvarToLVar =+    fmap (fmapTerm (fmap (foldBVar boundError id)))+  where+    boundError v = error $ "bvarToLVar: left-over bound variable '"+                           ++ show v ++ "'"++-- | Provided an 'Atom' does not contain a bound variable, it is converted to+-- the type of atoms without bound varaibles.+unbindAtom :: (Ord c, Ord v) => Atom (VTerm c (BVar v)) -> Maybe (Atom (VTerm c v))+unbindAtom = traverse (traverseTerm (traverse (foldBVar (const Nothing) Just)))+++------------------------------------------------------------------------------+-- Opening and Closing+------------------------------------------------------------------------------++-- | @openGuarded gf@ returns @Just (qua,vs,ats,gf')@ if @gf@ is a guarded+-- clause and @Nothing@ otherwise. In the first case, @quao@ is the quantifier,+-- @vs@ is a list of fresh variables, @ats@ is the antecedent, and @gf'@ is the+-- succedent. In both antecedent and succedent, the bound variables are+-- replaced by @vs@.+openGuarded :: (Ord c, MonadFresh m)+            => LGuarded c -> m (Maybe (Quantifier, [LVar], [Atom (VTerm c LVar)], LGuarded c))+openGuarded (GGuarded qua vs as gf) = do+    xs <- mapM (\(n,s) -> freshLVar n s) vs+    return $ Just (qua, xs, openas xs, opengf xs)+  where+    openas xs = map (bvarToLVar . substBoundAtom (subst xs)) as+    opengf xs = substBound (subst xs) gf+    subst xs  = zip [0..] (reverse xs)+openGuarded _ = return Nothing++-- | @closeGuarded vs ats gf@ is a smart constructor for @GGuarded@.+closeGuarded :: Ord c => Quantifier -> [LVar] -> [Atom (VTerm c LVar)]+             -> LGuarded c -> LGuarded c+closeGuarded qua vs as gf =+   (case qua of Ex -> gex; All -> gall) vs' as' gf'+ where+   as' = map (substFreeAtom s . fmap (fmapTerm (fmap Free))) as+   gf' = substFree s gf+   s   = zip (reverse vs) [0..]+   vs' = map (lvarName &&& lvarSort) vs+++------------------------------------------------------------------------------+-- Conversion and negation+------------------------------------------------------------------------------++type LNGuarded = Guarded (String,LSort) Name LVar++-- | @gtf b@ returns the guarded formula f with @b <-> f@.+gtf :: Bool -> Guarded s c v+gtf False = GDisj (Disj [])+gtf True  = GConj (Conj [])++-- | @gfalse@ returns the guarded formula f with @False <-> f@.+gfalse :: Guarded s c v+gfalse = gtf False++-- | @gtrue@ returns the guarded formula f with @True <-> f@.+gtrue :: Guarded s c v+gtrue = gtf True++-- | @gnotAtom a@ returns the guarded formula f with @not a <-> f@.+gnotAtom :: Atom (VTerm c (BVar v)) -> Guarded s c v+gnotAtom a  = GGuarded All [] [a] gfalse++-- | @gconj gfs@ smart constructor for the conjunction of gfs.+gconj :: (Ord s, Ord c, Ord v) => [Guarded s c v] -> Guarded s c v+gconj gfs0 = case concatMap flatten gfs0 of+    [gf]                      -> gf+    gfs | any (gfalse ==) gfs -> gfalse+        -- FIXME: See 'sortednub' below.+        | otherwise           -> GConj $ Conj $ nub gfs+  where+    flatten (GConj conj) = concatMap flatten $ getConj conj+    flatten gf           = [gf]++-- | @gdisj gfs@ smart constructor for the disjunction of gfs.+gdisj :: (Ord s, Ord c, Ord v) => [Guarded s c v] -> Guarded s c v+gdisj gfs0 = case concatMap flatten gfs0 of+    [gf]                     -> gf+    gfs | any (gtrue ==) gfs -> gtrue+        -- FIXME: Consider using 'sortednub' here. This yields stronger+        -- normalizaton for formulas. However, it also means that we loose+        -- invariance under renaming free variables, as the order changes,+        -- when they are renamed.+        | otherwise          -> GDisj $ Disj $ nub gfs+  where+    flatten (GDisj disj) = concatMap flatten $ getDisj disj+    flatten gf           = [gf]++-- @ A smart constructor for @GGuarded Ex@ that removes empty quantifications.+gex :: (Ord s, Ord c, Ord v)+    => [s] -> [Atom (VTerm c (BVar v))] -> Guarded s c v -> Guarded s c v+gex [] as gf = gconj (map GAto as ++ [gf])+gex ss as gf = GGuarded Ex ss as gf++-- @ A smart constructor for @GGuarded All@ that drops implications to 'gtrue'+-- and removes empty premises.+gall :: (Eq s, Eq c, Eq v)+     => [s] -> [Atom (VTerm c (BVar v))] -> Guarded s c v -> Guarded s c v+gall _  []   gf               = gf+gall _  _    gf | gf == gtrue = gtrue+gall ss atos gf               = GGuarded All ss atos gf++-- | @formulaToGuarded fm@ returns a guarded formula @gf@ that is+-- equivalent to @fm@ if possible.+formulaToGuarded :: LNFormula  -> Either String LNGuarded+formulaToGuarded = convert False++-- | @convert neg f@ returns @Nothing@ if @f@ cannot be converted,+-- @Just gf@ such that @mneg f <-> gf@ with @mneg = id@ if @neg@ is @False@+-- and @mneg=not@ if @neg@ is true.+convert :: Bool -> LNFormula  -> Either String LNGuarded+convert True  (Ato a) = pure $ gnotAtom a+convert False (Ato a) = pure $ GAto a++convert polarity (Not f) = convert (not polarity) f++convert True  (Conn And f g) = gdisj <$> mapM (convert True)  [f, g]+convert False (Conn And f g) = gconj <$> mapM (convert False) [f, g]++convert True  (Conn Or f g)  = gconj <$> mapM (convert True)  [f, g]+convert False (Conn Or f g)  = gdisj <$> mapM (convert False) [f, g]++convert True  (Conn Imp f g         ) =+    gconj <$> sequence [convert False f, convert True  g]+convert False (Conn Imp f g         ) =+    gdisj <$> sequence [convert True  f, convert False g]++convert polarity    (TF b) = pure $ gtf (polarity /= b)++convert polarity f0@(Qua qua0 _ _) =+    -- The quantifier switch stems from our implicit negation of the formula.+    case (qua0, polarity) of+      (All, True ) -> convAll Ex+      (All, False) -> convAll All+      (Ex,  True ) -> convEx  All+      (Ex,  False) -> convEx  Ex+  where+    convEx qua = do+      (xs,_,f) <- openFormulaPrefix f0 `evalFreshT` avoid f0+      case partitionEithers $ partitionConj f of+        (as, fs) -> do+          let guardedvars = frees as+              -- all existentially quantified variables must be guarded+              unguarded = xs \\ guardedvars++          unless (null unguarded) $ throwError $+              "unguarded variables " ++ show unguarded ++ " in " ++ show f0++          gf <- (if polarity then gdisj else gconj)+                  <$> mapM (convert polarity) fs+          return $ closeGuarded qua xs as gf+      where+        partitionConj (Conn And f1 f2)     = partitionConj f1 ++ partitionConj f2+        partitionConj (Ato a@(Action _ _)) = [Left $ bvarToLVar a]+        partitionConj (Ato e@(EqE _ _))    = [Left $ bvarToLVar e]+        partitionConj f                    = [Right f]++    convAll qua = do+      (xs,_,f) <- openFormulaPrefix f0 `evalFreshT` avoid f0+      case f of+        Conn Imp ante suc -> do+          allowedAtoms <- collectAllowedAtoms ante++          let guardedvars = frees [ a | a@(Action _ _) <- allowedAtoms ]+              -- all universally quantified variables must be guarded+              unguarded = xs \\ guardedvars++          when (not $ null unguarded) $ throwError $+              "unguarded variables " ++ show unguarded ++ " in " ++ show f0++          g <- convert polarity suc+          return $ closeGuarded qua xs allowedAtoms g++        _ -> throwError $ show f ++ "outside guarded fragment"+     where+      collectAllowedAtoms (Conn And f1 f2)     =+        (++) <$> collectAllowedAtoms f1 <*> collectAllowedAtoms f2+      collectAllowedAtoms (Ato a@(Action _ _)) = return [bvarToLVar a]+      collectAllowedAtoms (Ato e@(EqE _ _))    = return [bvarToLVar e]+      collectAllowedAtoms na                   =+        throwError $ show na ++ " not allowed in antecedent"++convert _     (Conn Iff _ _) =+  Left $ "`iff' not supported (yet)"++instance Apply LNGuarded where+  apply subst = mapGuardedAtoms (const $ apply subst)+++------------------------------------------------------------------------------+-- Induction over the trace+------------------------------------------------------------------------------++-- Note that we assume that the guarded formula describes the attack.+-- Hence, we want to show that it is false.++{-+-- | Checks if a doubly guarded formula is last-free; i.e., does not contain a 'Last'+-- atom.+lastFree :: Guarded s c v -> Bool+lastFree = error "lastFree: implement"++-- | Checks if a formula is doubly guarded; i.e., both universal and existential+-- quantifiers are guarded.+doublyGuarded :: Guarded s c v -> Bool+doublyGuarded = either (const False) (const True) . satisfiedByEmptyTrace+-}++-- | Negate a guarded formula.+gnot :: (Ord s, Ord c, Ord v)+              => Guarded s c v -> Guarded s c v+gnot =+    go+  where+    go (GGuarded All ss as gf) = gex  ss as $ go gf+    go (GGuarded Ex ss as gf)  = gall ss as $ go gf+    go (GAto ato)              = gnotAtom ato+    go (GDisj disj)            = gconj $ map go (getDisj disj)+    go (GConj conj)            = gdisj $ map go (getConj conj)+++-- | Checks if a doubly guarded formula is satisfied by the empty trace;+-- returns @'Left' errMsg@ if the formula is not doubly guarded.+satisfiedByEmptyTrace :: Guarded s c v -> Either String Bool+satisfiedByEmptyTrace =+  foldGuarded+    (\_ato -> throwError "atom outside the scope of a quantifier")+    (liftM or  . sequence . getDisj)+    (liftM and . sequence . getConj)+    (\qua _ss _as _gf -> return $ qua == All)+    -- the empty trace always satisfies guarded all-quantification+    -- and always dissatisfies guarded ex-quantification++-- | Tries to convert a doubly guarded formula to an induction hypothesis.+-- Returns @'Left' errMsg@ if the formula is not last-free or not doubly+-- guarded.+toInductionHypothesis :: Ord c => LGuarded c -> Either String (LGuarded c)+toInductionHypothesis =+    go+  where+    go (GGuarded qua ss as gf) = do+        gf' <- go gf+        return $ case qua of+          All -> gex  ss as (gconj $ (gnotAtom <$> lastAtos) ++ [gf'])+          Ex  -> gall ss as (gdisj $ (GAto <$> lastAtos) ++ [gf'])++      where+        lastAtos :: [Atom (VTerm c (BVar LVar))]+        lastAtos = do+            (j, (_, LSortNode)) <- zip [0..] $ reverse ss+            return $ Last (varTerm (Bound j))++    go (GAto (Less i j)) = return $ gdisj [GAto (EqE i j), GAto (Less j i)]+    go (GAto (Last _))   = throwError "formula not last-free"+    go (GAto ato)        = return $ gnotAtom ato+    go (GDisj disj)      = gconj <$> traverse go (getDisj disj)+    go (GConj conj)      = gdisj <$> traverse go (getConj conj)++-- | Try to prove the formula by applying induction over the trace.+-- Returns @'Left' errMsg@ if this is not possible.+ginduct :: Ord c => LGuarded c -> Either String (LGuarded c)+ginduct gf = do+    baseCase <- satisfiedByEmptyTrace gf+    if baseCase+      then throwError "cannot apply induction: empty trace is an attack"+      else do+        gfIH <- toInductionHypothesis gf+        return (gconj [gf, gfIH])++------------------------------------------------------------------------------+-- Formula Simplification+------------------------------------------------------------------------------++-- | Simplify a 'Guarded' formula by replacing atoms with their truth value,+-- if it can be determined.+simplifyGuarded :: (LNAtom -> Maybe Bool)+                -- ^ Partial assignment for truth value of atoms.+                -> LNGuarded+                -- ^ Original formula+                -> Maybe LNGuarded+                -- ^ Simplified formula, provided some simplification was+                -- performed.+simplifyGuarded valuation fm0+    | fm1 /= fm0 = trace (render ppMsg) (Just fm1)+    | otherwise  = Nothing+  where+    ppFm  = nest 2 . doubleQuotes . prettyGuarded+    ppMsg = nest 2 $ text "simplified formula:" $-$+                     nest 2 (vcat [ ppFm fm0, text "to", ppFm fm1])++    fm1 = simp fm0++    simp fm@(GAto ato)         = maybe fm gtf (valuation =<< unbindAtom ato)+    simp (GDisj fms)           = gdisj $ map simp $ getDisj fms+    simp (GConj fms)           = gconj $ map simp $ getConj fms+    simp (GGuarded All [] atos gf)+      | any ((Just False ==) . snd) annAtos = gtrue+      | otherwise                           =+          -- keep all atoms that we cannot evaluate yet.+          -- NOTE: Here we are missing the opportunity to change the valuation+          -- for evaluating the body 'gf'. We could add all atoms that we have+          -- as a premise.+          gall [] (fst <$> filter ((Nothing ==) . snd) annAtos) (simp gf)+      where+        -- cache the possibly expensive evaluation of the valuation+        annAtos = (\x -> (x, valuation =<< unbindAtom x)) <$> atos++    -- Note that existentials without quantifiers are already eliminated by+    -- 'gex'. Moreover, we dealay simplification inside guarded all+    -- quantification and guarded existential quantifiers. Their body will be+    -- simplified once the quantifiers are gone.+    simp fm@(GGuarded _ _ _ _) = fm+++------------------------------------------------------------------------------+-- Pretty Printing+------------------------------------------------------------------------------++-- | Pretty print a formula.+prettyGuarded :: HighlightDocument d+              => LNGuarded      -- ^ Guarded Formula.+              -> d              -- ^ Pretty printed formula.+prettyGuarded f =+    pp f `evalFreshAvoiding` f+  where+    pp :: HighlightDocument d => LNGuarded -> Fresh d+    pp (GAto a) = return $ prettyNAtom $ bvarToLVar a++    pp (GDisj (Disj [])) = return $ operator_ "F"++    pp (GDisj (Disj xs)) = do+        ps <- mapM (\x -> opParens <$> pp x) xs+        return $ sep $ punctuate (operator_ " |") ps++    pp (GConj (Conj [])) = return $ operator_ "T"++    pp (GConj (Conj xs)) = do+        ps <- mapM (\x -> opParens <$> pp x) xs+        return $ sep $ punctuate (operator_ " &") ps++    pp gf0@(GGuarded _ _ _ _) = do+      Just (qua, vs, atoms, gf) <- openGuarded gf0+      dante <- pp (GConj (Conj (map (GAto . fmap (fmapTerm (fmap Free))) atoms)))+      dsucc <- pp gf+      return $ sep [ operator_ (show qua) <-> ppVars vs <> operator_ "."+                   , nest 1 dante+                   , operator_ (case qua of All -> "==>"; Ex -> "&")+                   , nest 1 dsucc]+      where+        ppVars       = fsep . map (text . show)+++-- Derived instances+--------------------++$( derive makeBinary ''Guarded)+$( derive makeNFData ''Guarded)
− src/Theory/Fact.hs 
@@ -1,365 +0,0 @@-{-# LANGUAGE TemplateHaskell, FlexibleContexts, DeriveDataTypeable #-}-{-# LANGUAGE ViewPatterns #-}--- |--- Copyright   : (c) 2011, 2012 Benedikt Schmidt & Simon Meier--- License     : GPL v3 (see LICENSE)--- --- Maintainer  : Simon Meier <iridcode@gmail.com>--- Portability : GHC only------ Facts used to formulate and reason about protocol execution.-module Theory.Fact (--  -- * Fact-    Fact(..)-  , Multiplicity(..)-  , FactTag(..)--  -- ** Queries-  , isLinearFact   -  , isPersistentFact-  , isProtoFact--  , showFactTag-  , showFactTagArity-  , factTagArity-  , factTagMultiplicity-  , factArity-  , factMultiplicity--  -- ** Message deduction facts-  , ExpTag(..)-  , expTagToTerm-  , termToExpTag--  , DirTag(..)-  , kFactView-  , dedFactView-  , isKFact-  , kuFact-  , kdFact--  -- ** Construction-  , freshFact-  , outFact-  , inFact-  , kLogFact-  , dedLogFact-  , protoFact--  -- * NFact-  , NFact--  -- * LFact-  , LFact-  , LNFact-  , unifyLNFactEqs-  , unifiableLNFacts-  , matchLNFact--  -- * Pretty-Printing-  -  , prettyFact-  , prettyNFact-  , prettyLNFact--  -- * Convenience exports-  , module Term.Unification--  ) where--import Control.Basics-import Control.Monad.Fresh-import Control.DeepSeq--import Data.DeriveTH-import Data.Foldable (Foldable(..))-import Data.Traversable (Traversable(..))-import Data.Binary-import Data.Generics -import Data.Maybe (isJust)--import Term.Unification--import Text.PrettyPrint.Class------------------------------------------------------------------------------------ Fact---------------------------------------------------------------------------------data Multiplicity = Persistent | Linear-                  deriving( Eq, Ord, Show, Typeable, Data )---- | Fact tags/symbols-data FactTag = ProtoFact Multiplicity String Int-               -- ^ A protocol fact together with its arity and multiplicity.-             | FreshFact  -- ^ Freshly generated value.-             | OutFact    -- ^ Sent by the protocol-             | InFact     -- ^ Officially known by the intruder/network.-             | KUFact     -- ^ Up-knowledge fact in messsage deduction.-             | KDFact     -- ^ Down-knowledge fact in message deduction.-             | DedFact    -- ^ Log-fact denoting that the intruder deduced -                          -- a message using a construction rule.-    deriving( Eq, Ord, Show, Typeable, Data )---- | Facts.-data Fact t = Fact -    { factTag   :: FactTag -    , factTerms :: [t]-    }-    deriving( Eq, Ord, Show, Typeable, Data )----- Instances---------------instance Functor Fact where-    fmap f (Fact tag ts) = Fact tag (fmap f ts)--instance Foldable Fact where-    foldMap f (Fact _ ts) = foldMap f ts-    -instance Traversable Fact where-    sequenceA (Fact tag ts) = Fact tag <$> sequenceA ts-    traverse f (Fact tag ts) = Fact tag <$> traverse f ts--instance Sized t => Sized (Fact t) where-  size (Fact _ args) = size args--instance HasFrees t => HasFrees (Fact t) where-    foldFrees  f = foldMap  (foldFrees f)-    mapFrees   f = traverse (mapFrees f)--instance Apply t => Apply (Fact t) where-    apply subst = fmap (apply subst)----- KU and KD facts----------------------- | Message fact exponentation tag.-data ExpTag = CannotExp | CanExp-            deriving( Eq, Ord, Show)---- | Exponentiation-symbol to term.-expTagToTerm :: ExpTag -> LNTerm-expTagToTerm CannotExp   = lit (Con (Name PubName (NameId ("noexp"))))-expTagToTerm CanExp      = lit (Con (Name PubName (NameId ("exp"))))---- | Term to exponentiation-symbol.-termToExpTag :: LNTerm -> Maybe ExpTag-termToExpTag (viewTerm -> Lit (Con (Name PubName (NameId ("noexp"))))) = return CannotExp-termToExpTag (viewTerm -> Lit (Con (Name PubName (NameId ("exp")))))   = return CanExp-termToExpTag _                                             = mzero----- | A direction tag -data DirTag = UpK | DnK-            deriving( Eq, Ord, Show )---- | Construct a message fact. If no 'ExpTag' is given, then--- a fresh variable that matches any 'ExpTag' is constructed.-kuFact, kdFact :: MonadFresh m => Maybe ExpTag -> LNTerm -> m LNFact-kuFact = mkFact KUFact-kdFact = mkFact KDFact---- | A generic fact creation function.-mkFact :: MonadFresh m => FactTag -> Maybe ExpTag -> LNTerm -> m LNFact-mkFact tag (Just t) m = return $ Fact tag [expTagToTerm t, m]-mkFact tag Nothing  m = do-    v <- freshLVar "f_" LSortMsg-    return $ Fact tag [varTerm v, m]---- | View a message-deduction fact.-kFactView :: LNFact -> Maybe (DirTag, Maybe ExpTag, LNTerm)-kFactView fa = case fa of-    Fact KUFact [e, m] -> Just (UpK, termToExpTag e, m)-    Fact KUFact _      -> errMalformed "kFactView" fa-    Fact KDFact [e, m] -> Just (DnK, termToExpTag e, m)-    Fact KDFact _      -> errMalformed "kFactView" fa-    _                  -> Nothing---- | View a deduction logging fact.-dedFactView :: LNFact -> Maybe LNTerm-dedFactView fa = case fa of-    Fact DedFact [m] -> Just m-    Fact DedFact _   -> errMalformed "dedFactView" fa-    _                -> Nothing---- | True if the fact is a message-deduction fact.-isKFact :: LNFact -> Bool-isKFact = isJust . kFactView---- | Mark a fact as malformed.-errMalformed :: String -> LNFact -> a-errMalformed caller fa =-    error $ caller ++ show ": malformed fact: " ++ show fa---- Constructing facts-------------------------- | A fact denoting a message sent by the protocol to the intruder.-outFact :: t -> Fact t-outFact = Fact OutFact . return---- | A fresh fact denotes a fresh unguessable name.-freshFact :: t -> Fact t-freshFact = Fact FreshFact . return---- | A fact denoting that the intruder sent a message to the protocol.-inFact :: t -> Fact t-inFact = Fact InFact . return---- | A fact logging that the intruder knows a message.-kLogFact :: t -> Fact t-kLogFact = protoFact Linear "K" . return---- | A fact logging that the intruder deduced a message using a construction--- rule. We use this to formulate invariants over normal dependency graphs.-dedLogFact :: t -> Fact t-dedLogFact = Fact DedFact . return---- | A protocol fact denotes a fact generated by a protocol rule.-protoFact :: Multiplicity -> String -> [t] -> Fact t-protoFact multi name ts = Fact (ProtoFact multi name (length ts)) ts----- Queries on facts------------------------ | True iff the fact is a non-special protocol fact.-isProtoFact :: Fact t -> Bool-isProtoFact (Fact (ProtoFact _ _ _) _) = True-isProtoFact _                          = False---- | True if the fact is a linear fact.-isLinearFact :: Fact t -> Bool-isLinearFact = (Linear ==) . factMultiplicity---- | True if the fact is a persistent fact.-isPersistentFact :: Fact t -> Bool-isPersistentFact = (Persistent ==) . factMultiplicity---- | The multiplicity of a 'FactTag'.-factTagMultiplicity :: FactTag -> Multiplicity-factTagMultiplicity tag = case tag of -    ProtoFact multi _ _ -> multi-    KUFact              -> Persistent-    KDFact              -> Persistent-    _                   -> Linear---- | The arity of a 'FactTag'.-factTagArity :: FactTag -> Int-factTagArity tag = case tag of -    ProtoFact _ _ k -> k-    KUFact          -> 2-    KDFact          -> 2-    DedFact         -> 1-    FreshFact       -> 1-    InFact          -> 1-    OutFact         -> 1---- | The arity of a 'Fact'.-factArity :: Fact t -> Int-factArity (Fact tag ts)-  | length ts == k = k-  | otherwise      = error $ "factArity: tag of arity " ++ show k ++ -                             " applied to " ++ show (length ts) ++ " terms"-  where-    k = factTagArity tag---- | The multiplicity of a 'Fact'.-factMultiplicity :: Fact t -> Multiplicity-factMultiplicity = factTagMultiplicity . factTag------------------------------------------------------------------------------------ NFact----------------------------------------------------------------------------------- | Facts with literals containing names and arbitrary variables.-type NFact v = Fact (NTerm v)------------------------------------------------------------------------------------ LFact----------------------------------------------------------------------------------- | Facts with literals arbitrary constants and logical variables.-type LFact c = Fact (LTerm c)---- | Facts used for proving; i.e. variables fixed to logical variables--- and constant fixed to names.-type LNFact = Fact LNTerm---- | Unify a list of @LFact@ equalities.-unifyLNFactEqs :: [Equal LNFact] -> WithMaude [LNSubstVFresh]-unifyLNFactEqs eqs -  | all (evalEqual . fmap factTag) eqs = -      unifyLNTerm (map (fmap (fAppList . factTerms)) eqs)-  | otherwise = return []---- | 'True' iff the two facts are unifiable.-unifiableLNFacts :: LNFact -> LNFact -> WithMaude Bool-unifiableLNFacts fa1 fa2 = (not . null) <$> unifyLNFactEqs [Equal fa1 fa2]- --- | @matchLFact t p@ is a complete set of AC matchers for the term fact @t@--- and the pattern fact @p@.-matchLNFact :: LNFact -- ^ Term-            -> LNFact -- ^ Pattern-            -> WithMaude [LNSubst]-matchLNFact t p-  | (factTag t == factTag p && length (factTerms t) == length (factTerms p)) =-       matchLNTerm $ zipWith MatchWith (factTerms t) (factTerms p)-  | otherwise = return []------------------------------------------------------------------------------------ Pretty Printing----------------------------------------------------------------------------------- | Show a fact tag as a 'String'.-showFactTag :: FactTag -> String-showFactTag tag = case tag of-    KUFact            -> "!KU"-    KDFact            -> "!KD"-    DedFact           -> "Ded"-    InFact            -> "In"-    OutFact           -> "Out"-    FreshFact         -> "Fr"-    (ProtoFact m n _) -> multi m ++ n-  where-    multi Linear     = ""-    multi Persistent = "!"---- | Show a fact tag together with its aritiy.-showFactTagArity :: FactTag -> String-showFactTagArity tag = showFactTag tag ++ "/" ++ show (factTagArity tag)---- | Pretty print a fact.-prettyFact :: Document d => (t -> d) -> Fact t -> d-prettyFact ppTerm (Fact tag ts)-  | factTagArity tag /= length ts = ppFact ("MALFORMED-" ++ show tag) ts-  | otherwise                     = ppFact (showFactTag tag) ts-  where-    ppFact n = nestShort' (n ++ "(") ")" . fsep . punctuate comma . map ppTerm---- | Pretty print a 'NFact'.-prettyNFact :: Document d => LNFact -> d-prettyNFact = prettyFact prettyNTerm---- | Pretty print a 'LFact'.-prettyLNFact :: Document d => LNFact -> d-prettyLNFact fa = prettyFact prettyNTerm fa---- derived instances-----------------------$( derive makeBinary ''Multiplicity)-$( derive makeBinary ''FactTag)-$( derive makeBinary ''Fact)--$( derive makeNFData ''Multiplicity)-$( derive makeNFData ''FactTag)-$( derive makeNFData ''Fact)
− src/Theory/Formula.hs 
@@ -1,330 +0,0 @@-{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, BangPatterns #-}-{-# LANGUAGE TemplateHaskell, FlexibleInstances, TypeSynonymInstances #-}-{-# LANGUAGE ViewPatterns, StandaloneDeriving #-}-{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}-  -- spurious warnings for view patterns--- |--- Copyright   : (c) 2010-2012 Simon Meier & Benedikt Schmidt--- License     : GPL v3 (see LICENSE)--- --- Maintainer  : Simon Meier <iridcode@gmail.com>--- Portability : GHC only------ Types and operations for handling sorted first-order logic-module Theory.Formula (--   -- * Formulas-    Connective(..)-  , Quantifier(..)-  , Formula(..)-  , LNFormula-  , LFormula-  , FormulaE-  , FormulaAC--  , quantify-  , openFormula-  , openFormulaPrefix---  , unquantify--  -- ** More convenient constructors-  , lfalse-  , ltrue-  , (.&&.)-  , (.||.)-  , (.==>.)-  , (.<=>.)-  , exists-  , forall--  -- ** General Transformations-  , mapAtoms-  , foldFormula--  -- ** Pretty-Printing-  , prettyFormulaE-  , prettyFormulaAC--  -- * Convenience exports-  , module Theory.Atom--  ) where--import Prelude hiding (negate)--import Data.Monoid hiding (All)-import Data.Foldable (Foldable, foldMap)-import Data.Traversable-import Data.Generics-import Data.DeriveTH-import Data.Binary--import Control.DeepSeq-import Control.Basics-import Control.Monad.Fresh--import Theory.Atom--import Text.PrettyPrint.Highlight--import Term.LTerm-import Term.Substitution----------------------------------------------------------------------------------- Types----------------------------------------------------------------------------------- | Logical connectives.-data Connective = And | Or | Imp | Iff-                deriving( Eq, Ord, Show, Enum, Bounded, Data, Typeable )---- | Quantifiers.-data Quantifier = All | Ex-                deriving( Eq, Ord, Show, Enum, Bounded, Data, Typeable )----- | First-order formulas in locally nameless representation with hints for the--- names/sorts of quantified variables.-data Formula s c v = Ato (Atom (VTerm c (BVar v)))-                   | TF !Bool-                   | Not (Formula s c v)-                   | Conn !Connective (Formula s c v) (Formula s c v)-                   | Qua !Quantifier s (Formula s c v)---- Folding--------------- | Fold a formula.-{-# INLINE foldFormula #-}-foldFormula :: (Atom (VTerm c (BVar v)) -> b) -> (Bool -> b) -            -> (b -> b) -> (Connective -> b -> b -> b)-            -> (Quantifier -> s -> b -> b)-            -> Formula s c v-            -> b-foldFormula fAto fTF fNot fConn fQua = -    go-  where-    go (Ato a)       = fAto a-    go (TF b)        = fTF b-    go (Not p)       = fNot (go p)-    go (Conn c p q)  = fConn c (go p) (go q)-    go (Qua qua x p) = fQua qua x (go p)---- | Fold a formula.-{-# INLINE foldFormulaScope #-}-foldFormulaScope :: (Integer -> Atom (VTerm c (BVar v)) -> b) -> (Bool -> b)-                 -> (b -> b) -> (Connective -> b -> b -> b)-                 -> (Quantifier -> s -> b -> b)-                 -> Formula s c v-                 -> b-foldFormulaScope fAto fTF fNot fConn fQua =-    go 0-  where-    go !i (Ato a)       = fAto i a-    go _  (TF b)        = fTF b-    go !i (Not p)       = fNot (go i p)-    go !i (Conn c p q)  = fConn c (go i p) (go i q)-    go !i (Qua qua x p) = fQua qua x (go (succ i) p)----- Instances---------------{--instance Functor (Formula s c) where-    fmap f = foldFormula (Ato . fmap (fmap (fmap (fmap f)))) TF Not Conn Qua--}--instance Foldable (Formula s c) where-    foldMap f = foldFormula (foldMap (foldMap (foldMap (foldMap f)))) mempty id -                            (const mappend) (const $ const id)--traverseFormula :: (Ord v, Ord c, Ord v', Applicative f)-                => (v -> f v') -> Formula s c v -> f (Formula s c v')-traverseFormula f = foldFormula (liftA Ato . traverse (traverseTerm (traverse (traverse f))))-                                (pure . TF) (liftA Not)-                                (liftA2 . Conn) ((liftA .) . Qua)-{--instance Traversable (Formula a s) where-    traverse f = foldFormula (liftA Ato . traverseAtom (traverseTerm  (traverseLit (traverseBVar f))))-                             (pure . TF) (liftA Not)-                             (liftA2 . Conn) ((liftA .) . Qua)--}---- Abbreviations------------------ -infixl 3 .&&.-infixl 2 .||.-infixr 1 .==>.-infix  1 .<=>.---- | Logically true.-ltrue :: Formula a s v-ltrue = TF True---- | Logically false.-lfalse :: Formula a s v-lfalse = TF False--(.&&.), (.||.), (.==>.), (.<=>.) :: Formula a s v -> Formula a s v -> Formula a s v-(.&&.)  = Conn And-(.||.)  = Conn Or-(.==>.) = Conn Imp-(.<=>.) = Conn Iff----------------------------------------------------------------------------------- Dealing with bound variables----------------------------------------------------------------------------------- | @LFormula@ are FOL formulas with sorts abused to denote both a hint for--- the name of the bound variable, as well as the variable's actual sort.-type LFormula c = Formula (String, LSort) c LVar--type LNFormula = Formula (String, LSort) Name LVar---- | Change the representation of atoms.-mapAtoms :: (Integer -> Atom (VTerm c (BVar v))-         -> Atom (VTerm c1 (BVar v1)))-         -> Formula s c v -> Formula s c1 v1-mapAtoms f = foldFormulaScope (\i a -> Ato $ f i a) TF Not Conn Qua---- | @openFormula f@ returns @Just (v,Q,f')@ if @f = Q v. f'@ modulo--- alpha renaming and @Nothing otherwise@. @v@ is always chosen to be fresh.-openFormula :: (MonadFresh m, Ord c)-            => LFormula c -> Maybe (Quantifier, m (LVar, LFormula c))-openFormula (Qua qua (n,s) fm) = -    Just ( qua-         , do x <- freshLVar n s-              return $ (x, mapAtoms (\i a -> fmap (mapLits (subst x i)) a) fm)-         )-  where-    subst x i (Var (Bound i')) | i == i' = Var $ Free x-    subst _ _ l                          = l--openFormula _ = Nothing--mapLits :: (Ord a, Ord b) => (a -> b) -> Term a -> Term b-mapLits f (viewTerm -> Lit l) = lit . f $ l-mapLits f (viewTerm -> FApp o as) = fApp o (map (mapLits f) as)---- | @openFormulaPrefix f@ returns @Just (vs,Q,f')@ if @f = Q v_1 .. v_k. f'@--- modulo alpha renaming and @Nothing otherwise@. @vs@ is always chosen to be--- fresh.-openFormulaPrefix :: (MonadFresh m, Ord c)-                  => LFormula c -> m ([LVar], Quantifier, LFormula c)-openFormulaPrefix f0 = case openFormula f0 of-    Nothing        -> error $ "openFormulaPrefix: no outermost quantifier"-    Just (q, open) -> do -      (x, f) <- open-      go q [x] f-  where-    go q xs f = case openFormula f of-        Just (q', open') | q' == q -> do (x', f') <- open'-                                         go q (x' : xs) f'-        -- no further quantifier of the same kind => return result-        _ -> return (reverse xs, q, f)----- Instances---------------deriving instance Eq       LNFormula-deriving instance Show     LNFormula-deriving instance Ord      LNFormula--instance HasFrees LNFormula where-    foldFrees  f = foldMap  (foldFrees  f)-    mapFrees   f = traverseFormula (mapFrees   f)--instance Apply LNFormula where-    apply subst = mapAtoms (const $ apply subst)----------------------------------------------------------------------------------- Formulas modulo E and modulo AC---------------------------------------------------------------------------------type FormulaE  = LFormula Name-type FormulaAC = LFormula Name---- | Introduce a bound variable for a free variable.-quantify :: (Ord c, Ord v, Eq v) => v -> Formula s c v -> Formula s c v-quantify x =-    mapAtoms (\i a -> fmap (mapLits (fmap (>>= subst i))) a)-  where-    subst i v | v == x    = Bound i-              | otherwise = Free v---- | Create a universal quantification with a sort hint for the bound variable.-forall :: (Ord c, Ord v, Eq v) => s -> v -> Formula s c v -> Formula s c v-forall hint x = Qua All hint . quantify x---- | Create a existential quantification with a sort hint for the bound variable.-exists :: (Ord c, Ord v, Eq v) => s -> v -> Formula s c v -> Formula s c v-exists hint x = Qua Ex hint . quantify x----------------------------------------------------------------------------------- Pretty printing----------------------------------------------------------------------------------- | Pretty print a formula.-prettyLFormula :: (HighlightDocument d, MonadFresh m, Ord c) -              => (Atom (VTerm c LVar) -> d)  -- ^ Function for pretty printing atoms-              -> LFormula c -- ^ Formula to pretty print.-              -> m d              -- ^ Pretty printed formula.-prettyLFormula ppAtom =-    pp-  where-    extractFree (Free v)  = v-    extractFree (Bound i) = error $ "prettyFormula: illegal bound variable '" ++ show i ++ "'"--    pp (Ato a)    = return $ ppAtom (fmap (mapLits (fmap extractFree)) a)-    pp (TF True)  = return $ operator_ "T"                    -- "⊤" -    pp (TF False) = return $ operator_ "F"                    -- "⊥" --    pp (Not p)    = do-      p' <- pp p-      return $ operator_ "not" <> opParens p' -- text "¬" <> parens (pp a)--    pp (Conn op p q) = do-        p' <- pp p-        q' <- pp q-        return $ sep [opParens p' <-> operator_ (ppOp op), opParens q']-      where-        ppOp And = "&"   -- "∧"-        ppOp Or  = "|"   -- "∨"-        ppOp Imp = "==>" -- "⇒"-        ppOp Iff = "<=>" -- "⇔"--    pp fm@(Qua _ _ _) = do-        (vs,qua,fm') <- openFormulaPrefix fm-        d' <- pp fm' -        return $ sep -                 [ operator_ (ppQuant qua) <> ppVars vs <> operator_ "."-                 , nest 1 d']-      where-        ppVars       = fsep . map (text . show)--        ppQuant All = "All " -- "∀"-        ppQuant Ex  = "Ex "  -- "∃"--prettyFormulaAC, prettyFormulaE :: HighlightDocument d => FormulaE -> d-prettyFormulaE  = prettyLNFormula-prettyFormulaAC = prettyLNFormula---- | Pretty print a logical formula-prettyLNFormula :: HighlightDocument d => LNFormula -> d-prettyLNFormula fm = -  prettyLFormula prettyNAtom fm `evalFreshAvoiding` fm----- Derived instances-----------------------$( derive makeBinary ''Connective)-$( derive makeBinary ''Quantifier)-$( derive makeBinary ''Formula)--$( derive makeNFData ''Connective)-$( derive makeNFData ''Quantifier)-$( derive makeNFData ''Formula)
− src/Theory/IntruderRules.hs 
@@ -1,240 +0,0 @@-{-# LANGUAGE FlexibleContexts, ViewPatterns #-}-{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}-  -- spurious warnings for view patterns--- |--- Copyright   : (c) 2010-2012 Benedikt Schmidt--- License     : GPL v3 (see LICENSE)--- --- Maintainer  : Benedikt Schmidt <beschmi@gmail.com>--- Portability : GHC only----module Theory.IntruderRules (-    subtermIntruderRules-  , dhIntruderRules-  , specialIntruderRules---  , xorIntruderRules -- there are no multiset intruder rules-  ) where--import Control.Monad.Fresh-import Control.Basics-import Control.Monad.Reader--import qualified Data.Set as S-import Data.List-import qualified Data.ByteString.Char8 as BC--import Extension.Data.Label--import Utils.Misc--import Term.SubtermRule-import Term.Positions-import Term.Maude.Signature-import Term.Rewriting.Norm-import Term.Narrowing.Variants.Compute--import Theory.Rule------ Variants of intruder deduction rules----------------------------------------------------------------------------------------------------------------------------------------------------------- Special Intruder rules---------------------------------------------------------------------------------{--These are the special intruder that are always included.--rule (modulo AC) coerce:-   [ KD( f_, x ) ] --> [ KU( f_, x ) ]--rule (modulo AC) pub:-   [ ] --> [ KU( f_, $x ) ]--rule (modulo AC) gen_fresh:-   [ Fr( ~x ) ] --> [ KU( 'noexp', ~x ) ]--rule (modulo AC) isend:-   [ KU( f_, x) ] --[ K(x) ]-> [ In(x) ]---}-specialIntruderRules :: [IntrRuleAC]-specialIntruderRules =-    [ Rule CoerceRule-          [Fact KDFact [f_var, x_var]]-          [Fact KUFact [f_var,x_var]]-          [dedLogFact x_var]-    , Rule PubConstrRule-          []-          [Fact KUFact [f_var,x_pub_var]]-          [dedLogFact x_pub_var] -    , Rule FreshConstrRule-          [Fact FreshFact [x_fresh_var]]-          [Fact KUFact [f_var,x_fresh_var]]-          [dedLogFact x_fresh_var]-    , Rule ISendRule-          [Fact KUFact [f_var, x_var]]-          [Fact InFact [x_var]]-          [kLogFact x_var]-    , Rule IRecvRule-          [Fact OutFact [x_var]]-          [Fact KDFact [expTagToTerm CanExp, x_var]]-          []-    ]-  where-    f_var       = varTerm (LVar "f_" LSortMsg   0)-    x_var       = varTerm (LVar "x"  LSortMsg   0)-    x_pub_var   = varTerm (LVar "x"  LSortPub   0)-    x_fresh_var = varTerm (LVar "x"  LSortFresh 0)----------------------------------------------------------------------------------- Subterm Intruder theory---------------------------------------------------------------------------------destructionRules :: StRule -> [IntrRuleAC]-destructionRules (StRule lhs@(viewTerm -> FApp (NonAC (f,_)) _) (RhsPosition pos)) =-    go [] lhs pos-  where-    rhs = lhs `atPos` pos-    go _      _                       []     = []-    -- term already in premises-    go _      (viewTerm -> FApp _ _)  (_:[]) = []-    go uprems (viewTerm -> FApp _ as) (i:p)  =-        irule ++ go uprems' t' p-      where-        uprems' = uprems++[ t | (j, t) <- zip [0..] as, i /= j ]-        t'      = as!!i-        irule = if (t' /= rhs && rhs `notElem` uprems')-                 then (`evalFresh` avoid ([rhs,t']++uprems')) $ do-                     dfact <- kdFact Nothing t'-                     ufacts <- mapM (kuFact Nothing) uprems'-                     concfact <- kdFact (Just CanExp) rhs-                     return [ Rule (DestrRule (BC.unpack f)) (dfact:ufacts) [concfact] [] ]-                 else []-    go _      (viewTerm -> Lit _)     (_:_)  =-        error "IntruderRules.destructionRules: impossible, position invalid"--destructionRules _ = []---- | Simple removal of subsumed rules for auto-generated free intruder rules.-minimizeIntruderRules :: [IntrRuleAC] -> [IntrRuleAC]-minimizeIntruderRules rules =-    go [] rules-  where-    go checked [] = reverse checked-    go checked (r@(Rule _ prems concs _):unchecked) = go checked' unchecked-      where -        checked' = if any (\(Rule _ prems' concs' _)-                               -> map dropExpTag concs' == map dropExpTag concs &&-                                  map dropExpTag prems' `subsetOf` map dropExpTag prems)-                          (checked++unchecked)-                   then checked-                   else (r:checked)---- | @freeIntruderRules rus@ returns the set of intruder rules for---   the free (not Xor, DH, and MSet) part of the given signature.-subtermIntruderRules :: MaudeSig -> [IntrRuleAC]-subtermIntruderRules maudeSig =-     minimizeIntruderRules $ concatMap destructionRules (S.toList $ stRules maudeSig)-     ++ constructionRules (functionSymbols maudeSig)--constructionRules :: FunSig -> [IntrRuleAC]-constructionRules fSig =-    [ createRule s k | (s,k) <- S.toList fSig ]-  where-    createRule s k = (`evalFresh` nothingUsed) $ do-        vars     <- map varTerm <$> (sequence $ replicate k (freshLVar "x" LSortMsg))-        pfacts   <- mapM (kuFact Nothing) vars-        let m = fApp (NonAC (s,k)) vars-        concfact <- kuFact (Just CanExp) m-        return $ Rule (ConstrRule (BC.unpack s)) pfacts [concfact] [dedLogFact m]--dropExpTag :: Fact a -> Fact a-dropExpTag (Fact KUFact [_e,m]) = Fact KUFact [m]-dropExpTag (Fact KDFact [_e,m]) = Fact KDFact [m]-dropExpTag t                    = t----------------------------------------------------------------------------------- Diffie-Hellman Intruder Rules---------------------------------------------------------------------------------dhIntruderRules :: WithMaude [IntrRuleAC]-dhIntruderRules = reader $ \hnd -> minimizeIntruderRules $-    [ expRule ConstrRule kuFact (return . dedLogFact) -    , invRule ConstrRule kuFact (return . dedLogFact)-    ] ++ -    concatMap (variantsIntruder hnd) -      [ expRule DestrRule kdFact (const [])-      , invRule DestrRule kdFact (const [])-      ]-  where-    expRule mkInfo kudFact mkAction = (`evalFresh` nothingUsed) $ do-        b        <- varTerm <$> freshLVar "x" LSortMsg-        e        <- varTerm <$> freshLVar "x" LSortMsg-        bfact    <- kudFact (Just CanExp) b-        efact    <- kuFact Nothing e-        let conc = fAppExp (b, e)-        concfact <- kudFact (Just CannotExp) conc-        return $ Rule (mkInfo "exp") [bfact, efact] [concfact] (mkAction conc)--    invRule mkInfo kudFact mkAction = (`evalFresh` nothingUsed) $ do-        x        <- varTerm <$> freshLVar "x" LSortMsg-        bfact    <- kudFact Nothing x-        let conc = fAppInv x-        concfact <- kudFact (Just CanExp) conc-        return $ Rule (mkInfo "inv") [bfact] [concfact] (mkAction conc)---variantsIntruder :: MaudeHandle -> IntrRuleAC -> [IntrRuleAC]-variantsIntruder hnd ru = do-    let concTerms = concatMap factTerms-                              (get rPrems ru++get rConcs ru++get rActs ru)-    fsigma <- computeVariants (fAppList concTerms) `runReader` hnd-    let sigma     = freshToFree fsigma `evalFreshAvoiding` concTerms-        ruvariant = normRule' (apply sigma ru) `runReader` hnd-    guard (frees (get rConcs ruvariant) /= [] &&-           -- ground terms are already deducible by applying construction rules-           ruvariant /= ru &&-           -- this is a construction rule-           (map dropExpTag (get rConcs ruvariant))-           \\ (map dropExpTag (get rPrems ruvariant)) /= []-           -- The conclusion is included in the premises-           )--    case concatMap factTerms $ get rConcs ruvariant of-        [_, viewTerm -> FApp (AC Mult) _] ->-            fail "Rules with product conclusion are redundant"-        _                     -> return ruvariant---normRule' :: IntrRuleAC -> WithMaude IntrRuleAC-normRule' (Rule i ps cs as) = reader $ \hnd ->-    let normFactTerms = map (fmap (\t -> norm' t `runReader` hnd)) in-    Rule i (normFactTerms ps) (normFactTerms cs) (normFactTerms as)----{----------------------------------------------------------------------------------- Xor Intruder Rules---------------------------------------------------------------------------------xorIntruderRules :: WithMaude [IntrRuleAC]-xorIntruderRules = return []-  -- TODO: extend XOR tagging--maude :: IO MaudeHandle-maude = startMaude "maude" allMaudeSig--t :: IO ()-t = do-  m <- maude-  let rules = dhIntruderRules `runReader` m-  mapM_ (putStrLn . render . prettyIntrRuleAC) rules-  writeFile "/tmp/dhrules" $ unlines (map ((++"\n"). render . prettyIntrRuleAC) rules)-  putStrLn ("\nThere are " ++ show (length rules)-            ++ " and " ++ show (length rules - 3) ++ " of these are exp-down rules")--}
− src/Theory/Lexer.hs 
@@ -1,621 +0,0 @@-{-# LANGUAGE CPP,MagicHash #-}-{-# LINE 1 "src/Theory/Lexer.x" #-}--{-# OPTIONS_GHC -fno-warn-name-shadowing -fno-warn-unused-matches -fno-warn-unused-binds -fno-warn-missing-signatures -fno-warn-lazy-unlifted-bindings #-}-module Theory.Lexer where---#if __GLASGOW_HASKELL__ >= 603-#include "ghcconfig.h"-#elif defined(__GLASGOW_HASKELL__)-#include "config.h"-#endif-#if __GLASGOW_HASKELL__ >= 503-import Data.Array-import Data.Char (ord)-import Data.Array.Base (unsafeAt)-#else-import Array-import Char (ord)-#endif-#if __GLASGOW_HASKELL__ >= 503-import GHC.Exts-#else-import GlaExts-#endif-alex_base :: AlexAddr-alex_base = AlexA# "\x01\x00\x00\x00\xd9\x00\x00\x00\x4f\x01\x00\x00\x28\x00\x00\x00\x2c\x00\x00\x00\x2d\x00\x00\x00\x18\x00\x00\x00\x00\x00\x00\x00\x0e\x00\x00\x00\x00\x00\x00\x00\x0f\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x1a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1b\x00\x00\x00\x00\x00\x00\x00\x1c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x01\x00\x00\x6e\x02\x00\x00\x3e\x03\x00\x00\x0e\x04\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\xde\x04\x00\x00\xae\x05\x00\x00\x7e\x06\x00\x00\x4e\x07\x00\x00\x1e\x08\x00\x00\xee\x08\x00\x00\xbe\x09\x00\x00\x21\x00\x00\x00\x00\x00\x00\x00\x8e\x0a\x00\x00\x5e\x0b\x00\x00\x2e\x0c\x00\x00\xfe\x0c\x00\x00\xce\x0d\x00\x00\x9e\x0e\x00\x00\x6e\x0f\x00\x00\x3e\x10\x00\x00\x0e\x11\x00\x00\x22\x00\x00\x00\x00\x00\x00\x00\xc7\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf1\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x00\x00\x00\x00\xde\x11\x00\x00\xae\x12\x00\x00\x7e\x13\x00\x00"#--alex_table :: AlexAddr-alex_table = AlexA# "\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x03\x00\x4a\x00\x3d\x00\x44\x00\x42\x00\x45\x00\x4b\x00\x3c\x00\x08\x00\x35\x00\x46\x00\x50\x00\x34\x00\x4f\x00\x4d\x00\x06\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\xff\xff\xff\xff\x07\x00\x09\x00\x0b\x00\x41\x00\xff\xff\x47\x00\x40\x00\x48\x00\x49\x00\x43\x00\x0f\x00\x0d\x00\x30\x00\x10\x00\x12\x00\x04\x00\x03\x00\x14\x00\x16\x00\x1c\x00\x25\x00\x3a\x00\x00\x00\x53\x00\x52\x00\x54\x00\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x3b\x00\x37\x00\x3f\x00\x4e\x00\xff\xff\x51\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1d\x00\x17\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x00\x4c\x00\x39\x00\x3e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x33\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x0a\x00\x15\x00\x0e\x00\x15\x00\x15\x00\x15\x00\x15\x00\x11\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x0c\x00\x32\x00\x31\x00\x32\x00\x32\x00\x32\x00\x32\x00\x13\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x18\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x19\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x1a\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x1b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x1e\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x26\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x00\x00\x57\x00\x57\x00\x1f\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x20\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x21\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x22\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x23\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x00\x00\x57\x00\x27\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x28\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x29\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x00\x00\x57\x00\x57\x00\x2a\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x2b\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x2c\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x2d\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x2e\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x2f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00"#--alex_check :: AlexAddr-alex_check = AlexA# "\xff\xff\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0a\x00\x0a\x00\x2a\x00\x2a\x00\x2a\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x2a\x00\x29\x00\x7d\x00\x2a\x00\x2a\x00\x2f\x00\x20\x00\x2f\x00\x2a\x00\x2a\x00\x2a\x00\x5c\x00\xff\xff\x3e\x00\x2d\x00\x2d\x00\x2d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x3e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xd7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf7\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00"#--alex_deflt :: AlexAddr-alex_deflt = AlexA# "\x56\x00\xff\xff\xff\xff\xff\xff\x05\x00\x05\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"#--alex_accept = listArray (0::Int,88) [[],[],[],[(AlexAccSkip)],[(AlexAccSkip)],[(AlexAccSkip)],[(AlexAcc (alex_action_29))],[(AlexAcc (alex_action_2))],[(AlexAcc (alex_action_23))],[(AlexAcc (alex_action_3))],[(AlexAcc (alex_action_10))],[(AlexAcc (alex_action_4))],[(AlexAcc (alex_action_15))],[(AlexAcc (alex_action_5))],[(AlexAcc (alex_action_10))],[(AlexAcc (alex_action_6))],[(AlexAcc (alex_action_7))],[(AlexAcc (alex_action_10))],[(AlexAcc (alex_action_8))],[(AlexAcc (alex_action_15))],[(AlexAcc (alex_action_9))],[(AlexAcc (alex_action_10))],[(AlexAcc (alex_action_11))],[(AlexAcc (alex_action_56))],[(AlexAcc (alex_action_56))],[(AlexAcc (alex_action_56))],[(AlexAcc (alex_action_56))],[],[(AlexAcc (alex_action_12))],[(AlexAcc (alex_action_56))],[(AlexAcc (alex_action_56))],[(AlexAcc (alex_action_56))],[(AlexAcc (alex_action_56))],[(AlexAcc (alex_action_56))],[(AlexAcc (alex_action_56))],[(AlexAcc (alex_action_56))],[],[(AlexAcc (alex_action_13))],[(AlexAcc (alex_action_56))],[(AlexAcc (alex_action_56))],[(AlexAcc (alex_action_56))],[(AlexAcc (alex_action_56))],[(AlexAcc (alex_action_56))],[(AlexAcc (alex_action_56))],[(AlexAcc (alex_action_56))],[(AlexAcc (alex_action_56))],[(AlexAcc (alex_action_56))],[],[(AlexAcc (alex_action_14))],[(AlexAcc (alex_action_15))],[(AlexAcc (alex_action_15))],[(AlexAcc (alex_action_20))],[(AlexAcc (alex_action_22))],[(AlexAcc (alex_action_24))],[(AlexAcc (alex_action_25))],[(AlexAcc (alex_action_26))],[(AlexAcc (alex_action_27))],[(AlexAcc (alex_action_28))],[(AlexAcc (alex_action_30))],[],[(AlexAcc (alex_action_31))],[(AlexAcc (alex_action_32))],[(AlexAcc (alex_action_33))],[(AlexAcc (alex_action_34))],[(AlexAcc (alex_action_35))],[(AlexAcc (alex_action_36))],[(AlexAcc (alex_action_37))],[(AlexAcc (alex_action_38))],[(AlexAcc (alex_action_39))],[(AlexAcc (alex_action_40))],[(AlexAcc (alex_action_41))],[(AlexAcc (alex_action_42))],[(AlexAcc (alex_action_43))],[(AlexAcc (alex_action_44))],[(AlexAcc (alex_action_45))],[(AlexAcc (alex_action_46))],[(AlexAcc (alex_action_47))],[(AlexAcc (alex_action_48))],[(AlexAcc (alex_action_49))],[(AlexAcc (alex_action_50))],[(AlexAcc (alex_action_51))],[(AlexAcc (alex_action_52))],[(AlexAcc (alex_action_53))],[(AlexAcc (alex_action_54))],[],[(AlexAcc (alex_action_55))],[(AlexAcc (alex_action_56))],[(AlexAcc (alex_action_56))],[(AlexAcc (alex_action_56))]]-{-# LINE 84 "src/Theory/Lexer.x" #-}----- | Lex a keyword-keyword :: Keyword -> AlexAction Keyword-keyword kw input len = return kw---- | Wrap a string into a keyword-scanString :: (String -> Keyword) -> AlexAction Keyword-scanString kw (_,_,input) len = return $ kw (take len input)--{---- | Scan a string until EOF is encountered.-alexScanTokens :: String -> Either String [Keyword]-alexScanTokens inp = runAlex inp gather-  where-  gather = do-    t <- alexMonadScan-    case trace (show t) t of-      EOF -> return [EOF]-      _   -> (t:) `liftM` gather---- | Scan a file.-scanFile f = do-   inp <- readFile f-   return $ alexScanTokens inp--}---- | Formal text types.-data TextType = -       TextBegin String -     | TextContent String -     | TextEnd-     deriving( Eq, Ord, Show )---- | Lexable Keywords-data Keyword =-    IDENT String-  | TEXT TextType -  | SQUOTE-  | DQUOTE-  | RIGHTARROW-  | LEFTARROW-  | LONGRIGHTARROW-  | LONGLEFTARROW-  | COMMA-  | DOT-  | COLON-  | QUESTIONMARK-  | BANG-  | AND-  | MID-  | DOLLAR-  | AT-  | SHARP-  | PERCENT-  | LPAREN-  | RPAREN-  | LBRACKET-  | RBRACKET-  | LBRACE -  | RBRACE-  | SLASH-  | BACKSLASH-  | TILDE-  | HAT-  | STAR-  | UNDERSCORE-  | MINUS-  | PLUS-  | EQUAL-  | LESS-  | GREATER-  | EOF-  | FORALL-  | EXISTS-  | LAND-  | LOR-  | LNOT-  | APPROX-  -- dummy keyword to get rid of overlapping pattern matches-  | DUMMY_KEYWORD-  deriving( Eq )--instance Show Keyword where-  show kw = case kw of -      IDENT i -> identifier i-      TEXT t -> txt t-      SQUOTE -> symbol "'"-      DQUOTE -> symbol "\""-      RIGHTARROW -> symbol "->"-      LEFTARROW -> symbol "<-"-      LONGRIGHTARROW -> symbol "-->"-      LONGLEFTARROW -> symbol "<--"-      COMMA -> symbol ","-      DOT -> symbol "."-      COLON -> symbol ":"-      QUESTIONMARK -> symbol "?"-      BANG -> symbol "!"-      AND -> symbol "&"-      MID -> symbol "|"-      DOLLAR -> symbol "$"-      AT -> symbol "@"-      SHARP -> symbol "#"-      PERCENT -> symbol "%"-      LPAREN -> symbol "("-      RPAREN -> symbol ")"-      LBRACKET -> symbol "["-      RBRACKET -> symbol "]"-      LBRACE  -> symbol "{"-      RBRACE -> symbol "}"-      SLASH -> symbol "/"-      BACKSLASH -> symbol "\\"-      TILDE -> symbol "~"-      HAT -> symbol "^"-      STAR -> symbol "*"-      UNDERSCORE -> symbol "_"-      MINUS -> symbol "-"-      PLUS -> symbol "+"-      EQUAL -> symbol "="-      LESS -> symbol "<"-      GREATER -> symbol ">"-      EOF -> "end of file"-      FORALL -> symbol   "∀"  -      EXISTS -> symbol   "∃"  -      LAND -> symbol     "∧"  -      LOR -> symbol      "∨"  -      LNOT -> symbol     "¬"  -      APPROX -> symbol   "≈"  -      DUMMY_KEYWORD -> "DUMMY_KEYWORD (this should not occur!)"-    where-      identifier i        = "identifier `" ++ i ++ "'"-      txt (TextBegin t)   = "start of `" ++ t ++ "'"-      txt (TextContent t) = "text `" ++ t ++ "'"-      txt (TextEnd)       = "start of text"-      symbol s            = "symbol `" ++ s ++ "'"-      keyword s           = "keyword `" ++ s ++ "'"---- -------------------------------------------------------------------------------- Alex wrapper code.------ This code is in the PUBLIC DOMAIN; you may copy it freely and use--- it for any purpose whatsoever.---- -------------------------------------------------------------------------------- The input type---type AlexInput = (AlexPosn,     -- current position,-                  Char,         -- previous char-                  String)       -- current input string--alexInputPrevChar :: AlexInput -> Char-alexInputPrevChar (p,c,s) = c--alexGetChar :: AlexInput -> Maybe (Char,AlexInput)-alexGetChar (p,c,[]) = Nothing-alexGetChar (p,_,(c:s))  = let p' = alexMove p c in p' `seq`-                                Just (c, (p', c, s))----- -------------------------------------------------------------------------------- Token positions---- `Posn' records the location of a token in the input text.  It has three--- fields: the address (number of chacaters preceding the token), line number--- and column of a token within the file. `start_pos' gives the position of the--- start of the file and `eof_pos' a standard encoding for the end of file.--- `move_pos' calculates the new position after traversing a given character,--- assuming the usual eight character tab stops.--data AlexPosn = AlexPn !Int !Int !Int-        deriving (Eq)--instance Show AlexPosn where-  show (AlexPn _ l c) = "line "++show l++" column "++show c--alexStartPos :: AlexPosn-alexStartPos = AlexPn 0 1 1--alexMove :: AlexPosn -> Char -> AlexPosn-alexMove (AlexPn a l c) '\t' = AlexPn (a+1)  l     (((c+7) `div` 8)*8+1)-alexMove (AlexPn a l c) '\n' = AlexPn (a+1) (l+1)   1-alexMove (AlexPn a l c) _    = AlexPn (a+1)  l     (c+1)----- -------------------------------------------------------------------------------- Default monad---data AlexState = AlexState {-        alex_pos :: !AlexPosn,  -- position at current input location-        alex_inp :: String,     -- the current input-        alex_chr :: !Char,      -- the character before the input-        alex_scd :: !Int,       -- the current startcode-        alex_ocd :: !Int,       -- the old startcode before the comment started-        alex_cmt :: [String]    -- stack of begin comment identifiers-    }---- Compile with -funbox-strict-fields for best results!--runAlex :: String -> Alex a -> Either String a-runAlex input (Alex f) -   = case f (AlexState {alex_pos = alexStartPos,-                        alex_inp = input,       -                        alex_chr = '\n',-                        alex_scd = 0,-                        alex_ocd = 0,-                        alex_cmt = []-             }) of -       Left msg -> Left msg-       Right ( _, a ) -> Right a--newtype Alex a = Alex { unAlex :: AlexState -> Either String (AlexState, a) }--instance Monad Alex where-  m >>= k  = Alex $ \s -> case unAlex m s of -                                Left msg -> Left msg-                                Right (s',a) -> unAlex (k a) s'-  return a = Alex $ \s -> Right (s,a)--alexGetPos :: Alex AlexPosn-alexGetPos = Alex $ \s@AlexState{alex_pos=pos} -> Right (s, pos)--alexGetInput :: Alex AlexInput-alexGetInput- = Alex $ \s@AlexState{alex_pos=pos,alex_chr=c,alex_inp=inp} -> -        Right (s, (pos,c,inp))--alexSetInput :: AlexInput -> Alex ()-alexSetInput (pos,c,inp)- = Alex $ \s -> case s{alex_pos=pos,alex_chr=c,alex_inp=inp} of-                  s@(AlexState{}) -> Right (s, ())--alexError :: String -> Alex a-alexError message = Alex $ \s -> Left $ message ++ " in " ++ show (alex_pos s)--alexGetStartCode :: Alex Int-alexGetStartCode = Alex $ \s@AlexState{alex_scd=sc} -> Right (s, sc)--alexSetStartCode :: Int -> Alex ()-alexSetStartCode sc = Alex $ \s -> Right (s{alex_scd=sc}, ())--alexGetOldStartCode :: Alex Int-alexGetOldStartCode = Alex $ \s@AlexState{alex_ocd=sc} -> Right (s, sc)--alexSetOldStartCode :: Int -> Alex ()-alexSetOldStartCode sc = Alex $ \s -> Right (s{alex_ocd=sc}, ())--alexGetComments :: Alex [String]-alexGetComments = Alex $ \s -> Right (s, alex_cmt s)--alexSetComments :: [String] -> Alex ()-alexSetComments cmt = Alex $ \s -> Right (s{alex_cmt=cmt}, ())--alexMonadScan = do-  inp <- alexGetInput-  sc <- alexGetStartCode-  case alexScan inp sc of-    AlexEOF -> alexEOF-    AlexError inp' -> alexError "lexical error"-    AlexSkip  inp' len -> do-        alexSetInput inp'-        alexMonadScan-    AlexToken inp' len action -> do-        alexSetInput inp'-        action inp len---- -------------------------------------------------------------------------------- Useful token actions--type AlexAction result = AlexInput -> Int -> Alex result---- just ignore this token and scan another one-skip :: AlexAction Keyword-skip input len = alexMonadScan---- ignore this token, but set the start code to a new value-begin :: Int -> AlexAction Keyword-begin code input len = do alexSetStartCode code; alexMonadScan---- | Begin a text starting of the given type.-beginText :: String -> Int -> AlexAction Keyword-beginText ty code _ _ = do-  alexSetStartCode code-  return $ TEXT $ TextBegin ty---- | End a text.-endText :: Int -> AlexAction Keyword-endText code _ _ = do-  alexSetStartCode code-  return $ TEXT TextEnd---- | Begin a comment starting with the given sign.-beginComment :: String -> Int -> AlexAction Keyword-beginComment cmtBegin code input len = do-  cmts <- alexGetComments-  alexSetComments $ cmtBegin : cmts-  if null cmts-    then alexGetStartCode >>= alexSetOldStartCode-    else return ()-  alexSetStartCode code-  alexMonadScan---- | End a comment that started with the given begin comment sign.-endComment :: String -> AlexAction Keyword-endComment cmtBegin input len = do-  cmts <- alexGetComments-  case cmts of-    [] -> alexError $ "comment ended but no beginning '"++cmtBegin++"' marked."-    (cmt:cmts') -> do-      if cmt == cmtBegin -        then do-          alexSetComments cmts'-          if null cmts' -            then alexGetOldStartCode >>= alexSetStartCode -            else return ()-        else return ()-      alexMonadScan---- perform an action for this token, and set the start code to a new value--- andBegin :: AlexAction result -> Int -> AlexAction result-(action `andBegin` code) input len = do alexSetStartCode code; action input len--alexEOF :: Alex Keyword-alexEOF = return EOF------comment,text :: Int-comment = 1-text = 2-alex_action_2 =  beginComment "(*" comment -alex_action_3 =  beginComment "(*" comment -alex_action_4 =  beginComment "(*" comment -alex_action_5 =  endComment "(*" -alex_action_6 =  beginComment "/*" comment -alex_action_7 =  beginComment "/*" comment -alex_action_8 =  beginComment "/*" comment -alex_action_9 =  endComment "/*" -alex_action_10 =  skip -alex_action_11 =  beginText "text" text -alex_action_12 =  beginText "section" text -alex_action_13 =  beginText "subsection" text -alex_action_14 =  endText 0-alex_action_15 =  scanString (TEXT . TextContent) -alex_action_16 =  keyword FORALL -alex_action_17 =  keyword EXISTS -alex_action_18 =  keyword LAND -alex_action_19 =  keyword LOR -alex_action_20 =  keyword LNOT -alex_action_21 =  keyword APPROX -alex_action_22 =  keyword COMMA -alex_action_23 =  keyword LPAREN -alex_action_24 =  keyword RPAREN -alex_action_25 =  keyword LBRACKET -alex_action_26 =  keyword RBRACKET -alex_action_27 =  keyword LBRACE -alex_action_28 =  keyword RBRACE -alex_action_29 =  keyword SLASH -alex_action_30 =  keyword BACKSLASH -alex_action_31 =  keyword SQUOTE -alex_action_32 =  keyword DQUOTE -alex_action_33 =  keyword TILDE -alex_action_34 =  keyword HAT -alex_action_35 =  keyword EQUAL -alex_action_36 =  keyword COLON -alex_action_37 =  keyword DOLLAR -alex_action_38 =  keyword AT -alex_action_39 =  keyword SHARP -alex_action_40 =  keyword PERCENT -alex_action_41 =  keyword STAR -alex_action_42 =  keyword LESS -alex_action_43 =  keyword GREATER -alex_action_44 =  keyword QUESTIONMARK -alex_action_45 =  keyword BANG -alex_action_46 =  keyword AND -alex_action_47 =  keyword MID -alex_action_48 =  keyword DOT -alex_action_49 =  keyword UNDERSCORE -alex_action_50 =  keyword MINUS -alex_action_51 =  keyword PLUS -alex_action_52 =  keyword RIGHTARROW -alex_action_53 =  keyword LEFTARROW -alex_action_54 =  keyword LONGRIGHTARROW -alex_action_55 =  keyword LONGLEFTARROW -alex_action_56 =  scanString IDENT-{-# LINE 1 "templates/GenericTemplate.hs" #-}-{-# LINE 1 "templates/GenericTemplate.hs" #-}-{-# LINE 1 "<built-in>" #-}-{-# LINE 1 "<command-line>" #-}-{-# LINE 1 "templates/GenericTemplate.hs" #-}--- -------------------------------------------------------------------------------- ALEX TEMPLATE------ This code is in the PUBLIC DOMAIN; you may copy it freely and use--- it for any purpose whatsoever.---- -------------------------------------------------------------------------------- INTERNALS and main scanner engine--{-# LINE 37 "templates/GenericTemplate.hs" #-}--{-# LINE 47 "templates/GenericTemplate.hs" #-}---data AlexAddr = AlexA# Addr#--#if __GLASGOW_HASKELL__ < 503-uncheckedShiftL# = shiftL#-#endif--{-# INLINE alexIndexInt16OffAddr #-}-alexIndexInt16OffAddr (AlexA# arr) off =-#ifdef WORDS_BIGENDIAN-  narrow16Int# i-  where-        i    = word2Int# ((high `uncheckedShiftL#` 8#) `or#` low)-        high = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#)))-        low  = int2Word# (ord# (indexCharOffAddr# arr off'))-        off' = off *# 2#-#else-  indexInt16OffAddr# arr off-#endif------{-# INLINE alexIndexInt32OffAddr #-}-alexIndexInt32OffAddr (AlexA# arr) off = -#ifdef WORDS_BIGENDIAN-  narrow32Int# i-  where-   i    = word2Int# ((b3 `uncheckedShiftL#` 24#) `or#`-                     (b2 `uncheckedShiftL#` 16#) `or#`-                     (b1 `uncheckedShiftL#` 8#) `or#` b0)-   b3   = int2Word# (ord# (indexCharOffAddr# arr (off' +# 3#)))-   b2   = int2Word# (ord# (indexCharOffAddr# arr (off' +# 2#)))-   b1   = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#)))-   b0   = int2Word# (ord# (indexCharOffAddr# arr off'))-   off' = off *# 4#-#else-  indexInt32OffAddr# arr off-#endif------#if __GLASGOW_HASKELL__ < 503-quickIndex arr i = arr ! i-#else--- GHC >= 503, unsafeAt is available from Data.Array.Base.-quickIndex = unsafeAt-#endif------- -------------------------------------------------------------------------------- Main lexing routines--data AlexReturn a-  = AlexEOF-  | AlexError  !AlexInput-  | AlexSkip   !AlexInput !Int-  | AlexToken  !AlexInput !Int a---- alexScan :: AlexInput -> StartCode -> AlexReturn a-alexScan input (I# (sc))-  = alexScanUser undefined input (I# (sc))--alexScanUser user input (I# (sc))-  = case alex_scan_tkn user input 0# input sc AlexNone of-        (AlexNone, input') ->-                case alexGetChar input of-                        Nothing -> ----                                   AlexEOF-                        Just _ ->----                                   AlexError input'--        (AlexLastSkip input'' len, _) ->----                AlexSkip input'' len--        (AlexLastAcc k input''' len, _) ->----                AlexToken input''' len k----- Push the input through the DFA, remembering the most recent accepting--- state it encountered.--alex_scan_tkn user orig_input len input s last_acc =-  input `seq` -- strict in the input-  let -        new_acc = check_accs (alex_accept `quickIndex` (I# (s)))-  in-  new_acc `seq`-  case alexGetChar input of-     Nothing -> (new_acc, input)-     Just (c, new_input) -> ----        let-                (base) = alexIndexInt32OffAddr alex_base s-                ((I# (ord_c))) = ord c-                (offset) = (base +# ord_c)-                (check)  = alexIndexInt16OffAddr alex_check offset-                -                (new_s) = if (offset >=# 0#) && (check ==# ord_c)-                          then alexIndexInt16OffAddr alex_table offset-                          else alexIndexInt16OffAddr alex_deflt s-        in-        case new_s of -            -1# -> (new_acc, input)-                -- on an error, we want to keep the input *before* the-                -- character that failed, not after.-            _ -> alex_scan_tkn user orig_input (len +# 1#) -                        new_input new_s new_acc--  where-        check_accs [] = last_acc-        check_accs (AlexAcc a : _) = AlexLastAcc a input (I# (len))-        check_accs (AlexAccSkip : _)  = AlexLastSkip  input (I# (len))-        check_accs (AlexAccPred a predx : rest)-           | predx user orig_input (I# (len)) input-           = AlexLastAcc a input (I# (len))-        check_accs (AlexAccSkipPred predx : rest)-           | predx user orig_input (I# (len)) input-           = AlexLastSkip input (I# (len))-        check_accs (_ : rest) = check_accs rest--data AlexLastAcc a-  = AlexNone-  | AlexLastAcc a !AlexInput !Int-  | AlexLastSkip  !AlexInput !Int--data AlexAcc a user-  = AlexAcc a-  | AlexAccSkip-  | AlexAccPred a (AlexAccPred user)-  | AlexAccSkipPred (AlexAccPred user)--type AlexAccPred user = user -> AlexInput -> Int -> AlexInput -> Bool---- -------------------------------------------------------------------------------- Predicates on a rule--alexAndPred p1 p2 user in1 len in2-  = p1 user in1 len in2 && p2 user in1 len in2----alexPrevCharIsPred :: Char -> AlexAccPred _ -alexPrevCharIs c _ input _ _ = c == alexInputPrevChar input----alexPrevCharIsOneOfPred :: Array Char Bool -> AlexAccPred _ -alexPrevCharIsOneOf arr _ input _ _ = arr ! alexInputPrevChar input----alexRightContext :: Int -> AlexAccPred _-alexRightContext (I# (sc)) user _ _ input = -     case alex_scan_tkn user input 0# input sc AlexNone of-          (AlexNone, _) -> False-          _ -> True-        -- TODO: there's no need to find the longest-        -- match when checking the right context, just-        -- the first match will do.---- used by wrappers-iUnbox (I# (i)) = i
+ src/Theory/Model.hs view
@@ -0,0 +1,26 @@+-- |+-- Copyright   : (c) 2011-2012 Benedikt Schmidt & Simon Meier+-- License     : GPL v3 (see LICENSE)+--+-- Maintainer  : Simon Meier <iridcode@gmail.com>+-- Portability : GHC only+--+-- Security protocol model.+module Theory.Model (+    module Term.LTerm+  , module Term.Unification+  , module Theory.Model.Atom+  , module Theory.Model.Fact+  , module Theory.Model.Formula+  , module Theory.Model.Rule+  , module Theory.Model.Signature+  )+  where++import           Term.LTerm+import           Term.Unification+import           Theory.Model.Atom+import           Theory.Model.Fact+import           Theory.Model.Formula+import           Theory.Model.Rule+import           Theory.Model.Signature
+ src/Theory/Model/Atom.hs view
@@ -0,0 +1,132 @@+{-# LANGUAGE DeriveDataTypeable   #-}+-- {-# LANGUAGE FlexibleContexts     #-}+{-# LANGUAGE FlexibleInstances    #-}+-- {-# LANGUAGE StandaloneDeriving   #-}+{-# LANGUAGE TemplateHaskell      #-}+-- {-# LANGUAGE TupleSections        #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE ViewPatterns         #-}+-- {-# OPTIONS_GHC -fno-warn-orphans #-}+-- {-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}+  -- spurious warnings for view patterns+-- |+-- Copyright   : (c) 2011, 2012 Benedikt Schmidt & Simon Meier+-- License     : GPL v3 (see LICENSE)+--+-- Maintainer  : Simon Meier <iridcode@gmail.com>+-- Portability : GHC only+--+-- Formulas that represent security properties.+module Theory.Model.Atom(++  -- * Atoms+    Atom(..)+  , NAtom+  , LNAtom++  -- * LFormula+  , BLVar+  , BLAtom++  -- * Pretty-Printing+  , prettyNAtom+  )+where++import           Control.Basics+import           Control.DeepSeq++import           Data.Binary+import           Data.DeriveTH+import           Data.Foldable      (Foldable, foldMap)+import           Data.Generics+import           Data.Monoid        (mappend)+import           Data.Traversable++import           Term.LTerm+import           Term.Unification+import           Theory.Model.Fact+import           Theory.Text.Pretty+++------------------------------------------------------------------------------+-- Atoms+------------------------------------------------------------------------------++-- | @Atom@'s are the atoms of trace formulas parametrized over arbitrary+-- terms.+data Atom t = Action   t (Fact t)+            | EqE  t t+            | Less t t+            | Last t+            deriving( Eq, Ord, Show, Data, Typeable )++-- | @LAtom@ are the atoms we actually use in graph formulas input by the user.+type NAtom v = Atom (VTerm Name v)++-- | @LAtom@ are the atoms we actually use in graph formulas input by the user.+type LNAtom = Atom LNTerm++-- | Atoms built over 'BLTerm's.+type BLAtom = Atom BLTerm+++-- Instances+------------++instance Functor Atom where+    fmap f (Action   i fa) = Action    (f i) (fmap f fa)+    fmap f (EqE l r)       = EqE       (f l) (f r)+    fmap f (Less v u)      = Less      (f v) (f u)+    fmap f (Last i)        = Last      (f i)++instance Foldable Atom where+    foldMap f (Action i fa)   =+        f i `mappend` (foldMap f fa)+    foldMap f (EqE l r)       = f l `mappend` f r+    foldMap f (Less i j)      = f i `mappend` f j+    foldMap f (Last i)        = f i++instance Traversable Atom where+    traverse f (Action i fa)   =+        Action <$> f i <*> traverse f fa+    traverse f (EqE l r)       = EqE <$> f l <*> f r+    traverse f (Less v u)      = Less <$> f v <*> f u+    traverse f (Last i)        = Last <$> f i++instance HasFrees t => HasFrees (Atom t) where+    foldFrees f = foldMap (foldFrees f)+    mapFrees  f = traverse (mapFrees f)++instance Apply LNAtom where+    apply subst (Action i fact)   = Action (apply subst i) (apply subst fact)+    apply subst (EqE l r)         = EqE (apply subst l) (apply subst r)+    apply subst (Less i j)        = Less (apply subst i) (apply subst j)+    apply subst (Last i)          = Last (apply subst i)++instance Apply BLAtom where+    apply subst (Action i fact)   = Action (apply subst i) (apply subst fact)+    apply subst (EqE l r)         = EqE (apply subst l) (apply subst r)+    apply subst (Less i j)        = Less (apply subst i) (apply subst j)+    apply subst (Last i)          = Last (apply subst i)+++------------------------------------------------------------------------------+-- Pretty-Printing+------------------------------------------------------------------------------++prettyNAtom :: (Show v, HighlightDocument d) => NAtom v -> d+prettyNAtom (Action v fa) =+    prettyFact prettyNTerm fa <-> opAction <-> text (show v)+prettyNAtom (EqE l r) =+    sep [prettyNTerm l <-> opEqual, prettyNTerm r]+    -- sep [prettyNTerm l <-> text "≈", prettyNTerm r]+prettyNAtom (Less u v) = text (show u) <-> opLess <-> text (show v)+prettyNAtom (Last i)   = operator_ "Last" <> parens (text (show i))+++-- derived instances+--------------------++$( derive makeNFData ''Atom)+$( derive makeBinary ''Atom)
+ src/Theory/Model/Fact.hs view
@@ -0,0 +1,378 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts   #-}+{-# LANGUAGE TemplateHaskell    #-}+{-# LANGUAGE ViewPatterns       #-}+-- |+-- Copyright   : (c) 2011, 2012 Benedikt Schmidt & Simon Meier+-- License     : GPL v3 (see LICENSE)+--+-- Maintainer  : Simon Meier <iridcode@gmail.com>+-- Portability : GHC only+--+-- Facts used to formulate and reason about protocol execution.+module Theory.Model.Fact (++  -- * Fact+    Fact(..)+  , Multiplicity(..)+  , FactTag(..)++  , matchFact++  -- ** Queries+  , isLinearFact+  , isPersistentFact+  , isProtoFact++  , showFactTag+  , showFactTagArity+  , factTagArity+  , factTagMultiplicity+  , factArity+  , factMultiplicity++  -- ** Message deduction facts+  , ExpTag(..)+  , expTagToTerm+  , termToExpTag++  , DirTag(..)+  , kFactView+  , dedFactView+  , kuFact+  , kdFact++  , isKFact+  , isKUFact+  , isKDFact++  -- ** Construction+  , freshFact+  , outFact+  , inFact+  , kLogFact+  , dedLogFact+  , protoFact++  -- * NFact+  , NFact++  -- * LFact+  , LFact+  , LNFact+  , unifyLNFactEqs+  , unifiableLNFacts++  -- * Pretty-Printing++  , prettyFact+  , prettyNFact+  , prettyLNFact++  ) where++import           Control.Basics+import           Control.DeepSeq+import           Control.Monad.Fresh++import           Data.Binary+import           Data.DeriveTH+import           Data.Foldable          (Foldable(..))+import           Data.Generics+import           Data.Maybe             (isJust)+import           Data.Monoid+import           Data.Traversable       (Traversable(..))++import           Term.Unification++import           Text.PrettyPrint.Class+++------------------------------------------------------------------------------+-- Fact+------------------------------------------------------------------------------++data Multiplicity = Persistent | Linear+                  deriving( Eq, Ord, Show, Typeable, Data )++-- | Fact tags/symbols+data FactTag = ProtoFact Multiplicity String Int+               -- ^ A protocol fact together with its arity and multiplicity.+             | FreshFact  -- ^ Freshly generated value.+             | OutFact    -- ^ Sent by the protocol+             | InFact     -- ^ Officially known by the intruder/network.+             | KUFact     -- ^ Up-knowledge fact in messsage deduction.+             | KDFact     -- ^ Down-knowledge fact in message deduction.+             | DedFact    -- ^ Log-fact denoting that the intruder deduced+                          -- a message using a construction rule.+    deriving( Eq, Ord, Show, Typeable, Data )++-- | Facts.+data Fact t = Fact+    { factTag   :: FactTag+    , factTerms :: [t]+    }+    deriving( Eq, Ord, Show, Typeable, Data )+++-- Instances+------------++instance Functor Fact where+    fmap f (Fact tag ts) = Fact tag (fmap f ts)++instance Foldable Fact where+    foldMap f (Fact _ ts) = foldMap f ts++instance Traversable Fact where+    sequenceA (Fact tag ts) = Fact tag <$> sequenceA ts+    traverse f (Fact tag ts) = Fact tag <$> traverse f ts++instance Sized t => Sized (Fact t) where+  size (Fact _ args) = size args++instance HasFrees t => HasFrees (Fact t) where+    foldFrees  f = foldMap  (foldFrees f)+    mapFrees   f = traverse (mapFrees f)++instance Apply t => Apply (Fact t) where+    apply subst = fmap (apply subst)+++-- KU and KD facts+------------------++-- | Message fact exponentation tag.+data ExpTag = CannotExp | CanExp+            deriving( Eq, Ord, Show)++-- | Exponentiation-symbol to term.+expTagToTerm :: ExpTag -> LNTerm+expTagToTerm CannotExp   = lit (Con (Name PubName (NameId ("noexp"))))+expTagToTerm CanExp      = lit (Con (Name PubName (NameId ("exp"))))++-- | Term to exponentiation-symbol.+termToExpTag :: LNTerm -> Maybe ExpTag+termToExpTag (viewTerm -> Lit (Con (Name PubName (NameId ("noexp"))))) = return CannotExp+termToExpTag (viewTerm -> Lit (Con (Name PubName (NameId ("exp")))))   = return CanExp+termToExpTag _                                             = mzero+++-- | A direction tag+data DirTag = UpK | DnK+            deriving( Eq, Ord, Show )++-- | Construct a message fact. If no 'ExpTag' is given, then+-- a fresh variable that matches any 'ExpTag' is constructed.+kuFact, kdFact :: MonadFresh m => Maybe ExpTag -> LNTerm -> m LNFact+kuFact = mkFact KUFact+kdFact = mkFact KDFact++-- | A generic fact creation function.+mkFact :: MonadFresh m => FactTag -> Maybe ExpTag -> LNTerm -> m LNFact+mkFact tag (Just t) m = return $ Fact tag [expTagToTerm t, m]+mkFact tag Nothing  m = do+    v <- freshLVar "f_" LSortMsg+    return $ Fact tag [varTerm v, m]++-- | View a message-deduction fact.+kFactView :: LNFact -> Maybe (DirTag, Maybe ExpTag, LNTerm)+kFactView fa = case fa of+    Fact KUFact [e, m] -> Just (UpK, termToExpTag e, m)+    Fact KUFact _      -> errMalformed "kFactView" fa+    Fact KDFact [e, m] -> Just (DnK, termToExpTag e, m)+    Fact KDFact _      -> errMalformed "kFactView" fa+    _                  -> Nothing++-- | View a deduction logging fact.+dedFactView :: LNFact -> Maybe LNTerm+dedFactView fa = case fa of+    Fact DedFact [m] -> Just m+    Fact DedFact _   -> errMalformed "dedFactView" fa+    _                -> Nothing++-- | True if the fact is a message-deduction fact.+isKFact :: LNFact -> Bool+isKFact = isJust . kFactView++-- | True if the fact is a KU-fact.+isKUFact :: LNFact -> Bool+isKUFact (Fact KUFact _) = True+isKUFact _               = False++-- | True if the fact is a KD-fact.+isKDFact :: LNFact -> Bool+isKDFact (Fact KDFact _) = True+isKDFact _               = False++-- | Mark a fact as malformed.+errMalformed :: String -> LNFact -> a+errMalformed caller fa =+    error $ caller ++ show ": malformed fact: " ++ show fa++-- Constructing facts+---------------------++-- | A fact denoting a message sent by the protocol to the intruder.+outFact :: t -> Fact t+outFact = Fact OutFact . return++-- | A fresh fact denotes a fresh unguessable name.+freshFact :: t -> Fact t+freshFact = Fact FreshFact . return++-- | A fact denoting that the intruder sent a message to the protocol.+inFact :: t -> Fact t+inFact = Fact InFact . return++-- | A fact logging that the intruder knows a message.+kLogFact :: t -> Fact t+kLogFact = protoFact Linear "K" . return++-- | A fact logging that the intruder deduced a message using a construction+-- rule. We use this to formulate invariants over normal dependency graphs.+dedLogFact :: t -> Fact t+dedLogFact = Fact DedFact . return++-- | A protocol fact denotes a fact generated by a protocol rule.+protoFact :: Multiplicity -> String -> [t] -> Fact t+protoFact multi name ts = Fact (ProtoFact multi name (length ts)) ts+++-- Queries on facts+-------------------++-- | True iff the fact is a non-special protocol fact.+isProtoFact :: Fact t -> Bool+isProtoFact (Fact (ProtoFact _ _ _) _) = True+isProtoFact _                          = False++-- | True if the fact is a linear fact.+isLinearFact :: Fact t -> Bool+isLinearFact = (Linear ==) . factMultiplicity++-- | True if the fact is a persistent fact.+isPersistentFact :: Fact t -> Bool+isPersistentFact = (Persistent ==) . factMultiplicity++-- | The multiplicity of a 'FactTag'.+factTagMultiplicity :: FactTag -> Multiplicity+factTagMultiplicity tag = case tag of+    ProtoFact multi _ _ -> multi+    KUFact              -> Persistent+    KDFact              -> Persistent+    _                   -> Linear++-- | The arity of a 'FactTag'.+factTagArity :: FactTag -> Int+factTagArity tag = case tag of+    ProtoFact _ _ k -> k+    KUFact          -> 2+    KDFact          -> 2+    DedFact         -> 1+    FreshFact       -> 1+    InFact          -> 1+    OutFact         -> 1++-- | The arity of a 'Fact'.+factArity :: Fact t -> Int+factArity (Fact tag ts)+  | length ts == k = k+  | otherwise      = error $ "factArity: tag of arity " ++ show k +++                             " applied to " ++ show (length ts) ++ " terms"+  where+    k = factTagArity tag++-- | The multiplicity of a 'Fact'.+factMultiplicity :: Fact t -> Multiplicity+factMultiplicity = factTagMultiplicity . factTag+++------------------------------------------------------------------------------+-- NFact+------------------------------------------------------------------------------++-- | Facts with literals containing names and arbitrary variables.+type NFact v = Fact (NTerm v)+++------------------------------------------------------------------------------+-- LFact+------------------------------------------------------------------------------++-- | Facts with literals arbitrary constants and logical variables.+type LFact c = Fact (LTerm c)++-- | Facts used for proving; i.e. variables fixed to logical variables+-- and constant fixed to names.+type LNFact = Fact LNTerm++-- | Unify a list of @LFact@ equalities.+unifyLNFactEqs :: [Equal LNFact] -> WithMaude [LNSubstVFresh]+unifyLNFactEqs eqs+  | all (evalEqual . fmap factTag) eqs =+      unifyLNTerm (map (fmap (fAppList . factTerms)) eqs)+  | otherwise = return []++-- | 'True' iff the two facts are unifiable.+unifiableLNFacts :: LNFact -> LNFact -> WithMaude Bool+unifiableLNFacts fa1 fa2 = (not . null) <$> unifyLNFactEqs [Equal fa1 fa2]++-- | @matchLFact t p@ is a complete set of AC matchers for the term fact @t@+-- and the pattern fact @p@.+matchFact :: Fact t -- ^ Term+            -> Fact t -- ^ Pattern+            -> Match t+matchFact t p =+    matchOnlyIf (factTag t == factTag p &&+                 length (factTerms t) == length (factTerms p))+    <> mconcat (zipWith matchWith (factTerms t) (factTerms p))++------------------------------------------------------------------------------+-- Pretty Printing+------------------------------------------------------------------------------++-- | Show a fact tag as a 'String'.+showFactTag :: FactTag -> String+showFactTag tag = case tag of+    KUFact            -> "!KU"+    KDFact            -> "!KD"+    DedFact           -> "Ded"+    InFact            -> "In"+    OutFact           -> "Out"+    FreshFact         -> "Fr"+    (ProtoFact m n _) -> multi m ++ n+  where+    multi Linear     = ""+    multi Persistent = "!"++-- | Show a fact tag together with its aritiy.+showFactTagArity :: FactTag -> String+showFactTagArity tag = showFactTag tag ++ "/" ++ show (factTagArity tag)++-- | Pretty print a fact.+prettyFact :: Document d => (t -> d) -> Fact t -> d+prettyFact ppTerm (Fact tag ts)+  | factTagArity tag /= length ts = ppFact ("MALFORMED-" ++ show tag) ts+  | otherwise                     = ppFact (showFactTag tag) ts+  where+    ppFact n = nestShort' (n ++ "(") ")" . fsep . punctuate comma . map ppTerm++-- | Pretty print a 'NFact'.+prettyNFact :: Document d => LNFact -> d+prettyNFact = prettyFact prettyNTerm++-- | Pretty print a 'LFact'.+prettyLNFact :: Document d => LNFact -> d+prettyLNFact fa = prettyFact prettyNTerm fa++-- derived instances+--------------------++$( derive makeBinary ''Multiplicity)+$( derive makeBinary ''FactTag)+$( derive makeBinary ''Fact)++$( derive makeNFData ''Multiplicity)+$( derive makeNFData ''FactTag)+$( derive makeNFData ''Fact)
+ src/Theory/Model/Formula.hs view
@@ -0,0 +1,330 @@+{-# LANGUAGE BangPatterns         #-}+{-# LANGUAGE DeriveDataTypeable   #-}+{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE StandaloneDeriving   #-}+{-# LANGUAGE TemplateHaskell      #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE ViewPatterns         #-}+-- |+-- Copyright   : (c) 2010-2012 Simon Meier & Benedikt Schmidt+-- License     : GPL v3 (see LICENSE)+--+-- Maintainer  : Simon Meier <iridcode@gmail.com>+-- Portability : GHC only+--+-- Types and operations for handling sorted first-order logic+module Theory.Model.Formula (++   -- * Formulas+    Connective(..)+  , Quantifier(..)+  , Formula(..)+  , LNFormula+  , LFormula+  , FormulaE+  , FormulaAC++  , quantify+  , openFormula+  , openFormulaPrefix+--  , unquantify++  -- ** More convenient constructors+  , lfalse+  , ltrue+  , (.&&.)+  , (.||.)+  , (.==>.)+  , (.<=>.)+  , exists+  , forall++  -- ** General Transformations+  , mapAtoms+  , foldFormula++  -- ** Pretty-Printing+  , prettyFormulaE+  , prettyFormulaAC++  ) where++import           Prelude                    hiding (negate)++import           Data.Binary+import           Data.DeriveTH+import           Data.Foldable              (Foldable, foldMap)+import           Data.Generics+import           Data.Monoid                hiding (All)+import           Data.Traversable++import           Control.Basics+import           Control.DeepSeq+import           Control.Monad.Fresh++import           Theory.Model.Atom++import           Text.PrettyPrint.Highlight++import           Term.LTerm+import           Term.Substitution++------------------------------------------------------------------------------+-- Types+------------------------------------------------------------------------------++-- | Logical connectives.+data Connective = And | Or | Imp | Iff+                deriving( Eq, Ord, Show, Enum, Bounded, Data, Typeable )++-- | Quantifiers.+data Quantifier = All | Ex+                deriving( Eq, Ord, Show, Enum, Bounded, Data, Typeable )+++-- | First-order formulas in locally nameless representation with hints for the+-- names/sorts of quantified variables.+data Formula s c v = Ato (Atom (VTerm c (BVar v)))+                   | TF !Bool+                   | Not (Formula s c v)+                   | Conn !Connective (Formula s c v) (Formula s c v)+                   | Qua !Quantifier s (Formula s c v)++-- Folding+----------++-- | Fold a formula.+{-# INLINE foldFormula #-}+foldFormula :: (Atom (VTerm c (BVar v)) -> b) -> (Bool -> b)+            -> (b -> b) -> (Connective -> b -> b -> b)+            -> (Quantifier -> s -> b -> b)+            -> Formula s c v+            -> b+foldFormula fAto fTF fNot fConn fQua =+    go+  where+    go (Ato a)       = fAto a+    go (TF b)        = fTF b+    go (Not p)       = fNot (go p)+    go (Conn c p q)  = fConn c (go p) (go q)+    go (Qua qua x p) = fQua qua x (go p)++-- | Fold a formula.+{-# INLINE foldFormulaScope #-}+foldFormulaScope :: (Integer -> Atom (VTerm c (BVar v)) -> b) -> (Bool -> b)+                 -> (b -> b) -> (Connective -> b -> b -> b)+                 -> (Quantifier -> s -> b -> b)+                 -> Formula s c v+                 -> b+foldFormulaScope fAto fTF fNot fConn fQua =+    go 0+  where+    go !i (Ato a)       = fAto i a+    go _  (TF b)        = fTF b+    go !i (Not p)       = fNot (go i p)+    go !i (Conn c p q)  = fConn c (go i p) (go i q)+    go !i (Qua qua x p) = fQua qua x (go (succ i) p)+++-- Instances+------------++{-+instance Functor (Formula s c) where+    fmap f = foldFormula (Ato . fmap (fmap (fmap (fmap f)))) TF Not Conn Qua+-}++instance Foldable (Formula s c) where+    foldMap f = foldFormula (foldMap (foldMap (foldMap (foldMap f)))) mempty id+                            (const mappend) (const $ const id)++traverseFormula :: (Ord v, Ord c, Ord v', Applicative f)+                => (v -> f v') -> Formula s c v -> f (Formula s c v')+traverseFormula f = foldFormula (liftA Ato . traverse (traverseTerm (traverse (traverse f))))+                                (pure . TF) (liftA Not)+                                (liftA2 . Conn) ((liftA .) . Qua)+{-+instance Traversable (Formula a s) where+    traverse f = foldFormula (liftA Ato . traverseAtom (traverseTerm  (traverseLit (traverseBVar f))))+                             (pure . TF) (liftA Not)+                             (liftA2 . Conn) ((liftA .) . Qua)+-}++-- Abbreviations+----------------++infixl 3 .&&.+infixl 2 .||.+infixr 1 .==>.+infix  1 .<=>.++-- | Logically true.+ltrue :: Formula a s v+ltrue = TF True++-- | Logically false.+lfalse :: Formula a s v+lfalse = TF False++(.&&.), (.||.), (.==>.), (.<=>.) :: Formula a s v -> Formula a s v -> Formula a s v+(.&&.)  = Conn And+(.||.)  = Conn Or+(.==>.) = Conn Imp+(.<=>.) = Conn Iff++------------------------------------------------------------------------------+-- Dealing with bound variables+------------------------------------------------------------------------------++-- | @LFormula@ are FOL formulas with sorts abused to denote both a hint for+-- the name of the bound variable, as well as the variable's actual sort.+type LFormula c = Formula (String, LSort) c LVar++type LNFormula = Formula (String, LSort) Name LVar++-- | Change the representation of atoms.+mapAtoms :: (Integer -> Atom (VTerm c (BVar v))+         -> Atom (VTerm c1 (BVar v1)))+         -> Formula s c v -> Formula s c1 v1+mapAtoms f = foldFormulaScope (\i a -> Ato $ f i a) TF Not Conn Qua++-- | @openFormula f@ returns @Just (v,Q,f')@ if @f = Q v. f'@ modulo+-- alpha renaming and @Nothing otherwise@. @v@ is always chosen to be fresh.+openFormula :: (MonadFresh m, Ord c)+            => LFormula c -> Maybe (Quantifier, m (LVar, LFormula c))+openFormula (Qua qua (n,s) fm) =+    Just ( qua+         , do x <- freshLVar n s+              return $ (x, mapAtoms (\i a -> fmap (mapLits (subst x i)) a) fm)+         )+  where+    subst x i (Var (Bound i')) | i == i' = Var $ Free x+    subst _ _ l                          = l++openFormula _ = Nothing++mapLits :: (Ord a, Ord b) => (a -> b) -> Term a -> Term b+mapLits f t = case viewTerm t of+    Lit l     -> lit . f $ l+    FApp o as -> fApp o (map (mapLits f) as)++-- | @openFormulaPrefix f@ returns @Just (vs,Q,f')@ if @f = Q v_1 .. v_k. f'@+-- modulo alpha renaming and @Nothing otherwise@. @vs@ is always chosen to be+-- fresh.+openFormulaPrefix :: (MonadFresh m, Ord c)+                  => LFormula c -> m ([LVar], Quantifier, LFormula c)+openFormulaPrefix f0 = case openFormula f0 of+    Nothing        -> error $ "openFormulaPrefix: no outermost quantifier"+    Just (q, open) -> do+      (x, f) <- open+      go q [x] f+  where+    go q xs f = case openFormula f of+        Just (q', open') | q' == q -> do (x', f') <- open'+                                         go q (x' : xs) f'+        -- no further quantifier of the same kind => return result+        _ -> return (reverse xs, q, f)+++-- Instances+------------++deriving instance Eq       LNFormula+deriving instance Show     LNFormula+deriving instance Ord      LNFormula++instance HasFrees LNFormula where+    foldFrees  f = foldMap  (foldFrees  f)+    mapFrees   f = traverseFormula (mapFrees   f)++instance Apply LNFormula where+    apply subst = mapAtoms (const $ apply subst)++------------------------------------------------------------------------------+-- Formulas modulo E and modulo AC+------------------------------------------------------------------------------++type FormulaE  = LFormula Name+type FormulaAC = LFormula Name++-- | Introduce a bound variable for a free variable.+quantify :: (Ord c, Ord v, Eq v) => v -> Formula s c v -> Formula s c v+quantify x =+    mapAtoms (\i a -> fmap (mapLits (fmap (>>= subst i))) a)+  where+    subst i v | v == x    = Bound i+              | otherwise = Free v++-- | Create a universal quantification with a sort hint for the bound variable.+forall :: (Ord c, Ord v, Eq v) => s -> v -> Formula s c v -> Formula s c v+forall hint x = Qua All hint . quantify x++-- | Create a existential quantification with a sort hint for the bound variable.+exists :: (Ord c, Ord v, Eq v) => s -> v -> Formula s c v -> Formula s c v+exists hint x = Qua Ex hint . quantify x++------------------------------------------------------------------------------+-- Pretty printing+------------------------------------------------------------------------------++-- | Pretty print a formula.+prettyLFormula :: (HighlightDocument d, MonadFresh m, Ord c)+              => (Atom (VTerm c LVar) -> d)  -- ^ Function for pretty printing atoms+              -> LFormula c -- ^ Formula to pretty print.+              -> m d              -- ^ Pretty printed formula.+prettyLFormula ppAtom =+    pp+  where+    extractFree (Free v)  = v+    extractFree (Bound i) = error $ "prettyFormula: illegal bound variable '" ++ show i ++ "'"++    pp (Ato a)    = return $ ppAtom (fmap (mapLits (fmap extractFree)) a)+    pp (TF True)  = return $ operator_ "T"                    -- "⊤"+    pp (TF False) = return $ operator_ "F"                    -- "⊥"++    pp (Not p)    = do+      p' <- pp p+      return $ operator_ "not" <> opParens p' -- text "¬" <> parens (pp a)++    pp (Conn op p q) = do+        p' <- pp p+        q' <- pp q+        return $ sep [opParens p' <-> operator_ (ppOp op), opParens q']+      where+        ppOp And = "&"   -- "∧"+        ppOp Or  = "|"   -- "∨"+        ppOp Imp = "==>" -- "⇒"+        ppOp Iff = "<=>" -- "⇔"++    pp fm@(Qua _ _ _) = do+        (vs,qua,fm') <- openFormulaPrefix fm+        d' <- pp fm'+        return $ sep+                 [ operator_ (ppQuant qua) <> ppVars vs <> operator_ "."+                 , nest 1 d']+      where+        ppVars       = fsep . map (text . show)++        ppQuant All = "All " -- "∀"+        ppQuant Ex  = "Ex "  -- "∃"++prettyFormulaAC, prettyFormulaE :: HighlightDocument d => FormulaE -> d+prettyFormulaE  = prettyLNFormula+prettyFormulaAC = prettyLNFormula++-- | Pretty print a logical formula+prettyLNFormula :: HighlightDocument d => LNFormula -> d+prettyLNFormula fm =+  prettyLFormula prettyNAtom fm `evalFreshAvoiding` fm+++-- Derived instances+--------------------++$( derive makeBinary ''Connective)+$( derive makeBinary ''Quantifier)+$( derive makeBinary ''Formula)++$( derive makeNFData ''Connective)+$( derive makeNFData ''Quantifier)+$( derive makeNFData ''Formula)
+ src/Theory/Model/Rule.hs view
@@ -0,0 +1,631 @@+{-# LANGUAGE DeriveDataTypeable         #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TemplateHaskell            #-}+{-# LANGUAGE TypeOperators              #-}+{-# LANGUAGE TypeSynonymInstances       #-}+-- |+-- Copyright   : (c) 2010-2012 Benedikt Schmidt & Simon Meier+-- License     : GPL v3 (see LICENSE)+--+-- Maintainer  : Simon Meier <iridcode@gmail.com>+-- Portability : portable+--+-- Rewriting rules representing protocol execution and intruder deduction. Once+-- modulo the full Diffie-Hellman equational theory and once modulo AC.+module Theory.Model.Rule (+  -- * General Rules+    Rule(..)+  , PremIdx(..)+  , ConcIdx(..)++  -- ** Accessors+  , rInfo+  , rPrems+  , rConcs+  , rActs+  , rPrem+  , rConc+  , lookupPrem+  , lookupConc+  , enumPrems+  , enumConcs++  -- ** Genereal protocol and intruder rules+  , RuleInfo(..)+  , ruleInfo++  -- * Protocol Rule Information+  , ProtoRuleName(..)+  , ProtoRuleACInfo(..)+  , pracName+  , pracVariants+  , pracLoopBreakers+  , ProtoRuleACInstInfo(..)+  , praciName+  , praciLoopBreakers+  , RuleACConstrs++  -- * Intruder Rule Information+  , IntrRuleACInfo(..)++  -- * Concrete Rules+  , ProtoRuleE+  , ProtoRuleAC+  , IntrRuleAC+  , RuleAC+  , RuleACInst++  -- ** Queries+  , HasRuleName(..)+  , isIntruderRule+  , isDestrRule+  , isConstrRule+  , isFreshRule+  , isIRecvRule+  , isISendRule+  , isCoerceRule+  , nfRule+  , isTrivialProtoVariantAC++  -- ** Conversion+  , ruleACToIntrRuleAC+  , ruleACIntrToRuleAC++  -- ** Construction+  , someRuleACInst++  -- ** Unification+  , unifyRuleACInstEqs+  , unifiableRuleACInsts++  -- * Pretty-Printing+  , showRuleCaseName+  , prettyProtoRuleName+  , prettyRuleName+  , prettyProtoRuleE+  , prettyProtoRuleAC+  , prettyIntrRuleAC+  , prettyIntrRuleACInfo+  , prettyRuleAC+  , prettyLoopBreakers+  , prettyRuleACInst++  )  where++import           Prelude              hiding (id, (.))++import           Data.Binary+import           Data.DeriveTH+import           Data.Foldable        (foldMap)+import           Data.Generics+import           Data.List+import           Data.Monoid+import           Safe++import           Control.Basics+import           Control.Category+import           Control.DeepSeq+import           Control.Monad.Bind+import           Control.Monad.Reader++import           Extension.Data.Label hiding (get)+import qualified Extension.Data.Label as L+import           Logic.Connectives++import           Term.LTerm+import           Term.Rewriting.Norm  (nf')+import           Term.Unification+import           Theory.Model.Fact+import           Theory.Text.Pretty++------------------------------------------------------------------------------+-- General Rule+------------------------------------------------------------------------------++-- | Rewriting rules with arbitrary additional information and facts with names+-- and logical variables.+data Rule i = Rule {+         _rInfo  :: i+       , _rPrems :: [LNFact]+       , _rConcs :: [LNFact]+       , _rActs  :: [LNFact]+       }+       deriving( Eq, Ord, Show, Data, Typeable )++$(mkLabels [''Rule])++-- | An index of a premise. The first premise has index '0'.+newtype PremIdx = PremIdx { getPremIdx :: Int }+  deriving( Eq, Ord, Show, Enum, Data, Typeable, Binary, NFData )++-- | An index of a conclusion. The first conclusion has index '0'.+newtype ConcIdx = ConcIdx { getConcIdx :: Int }+  deriving( Eq, Ord, Show, Enum, Data, Typeable, Binary, NFData )++-- | @lookupPrem i ru@ returns the @i@-th premise of rule @ru@, if possible.+lookupPrem :: PremIdx -> Rule i -> Maybe LNFact+lookupPrem i = (`atMay` getPremIdx i) . L.get rPrems++-- | @lookupConc i ru@ returns the @i@-th conclusion of rule @ru@, if possible.+lookupConc :: ConcIdx -> Rule i -> Maybe LNFact+lookupConc i = (`atMay` getConcIdx i) . L.get rConcs++-- | @rPrem i@ is a lens for the @i@-th premise of a rule.+rPrem :: PremIdx -> (Rule i :-> LNFact)+rPrem i = nthL (getPremIdx i) . rPrems++-- | @rConc i@ is a lens for the @i@-th conclusion of a rule.+rConc :: ConcIdx -> (Rule i :-> LNFact)+rConc i = nthL (getConcIdx i) . rConcs++-- | Enumerate all premises of a rule.+enumPrems :: Rule i -> [(PremIdx, LNFact)]+enumPrems = zip [(PremIdx 0)..] . L.get rPrems++-- | Enumerate all conclusions of a rule.+enumConcs :: Rule i -> [(ConcIdx, LNFact)]+enumConcs = zip [(ConcIdx 0)..] . L.get rConcs++-- Instances+------------++instance Functor Rule where+    fmap f (Rule i ps cs as) = Rule (f i) ps cs as++instance HasFrees i => HasFrees (Rule i) where+    foldFrees f (Rule i ps cs as) =+        (foldFrees f i  `mappend`) $+        (foldFrees f ps `mappend`) $+        (foldFrees f cs `mappend`) $+        (foldFrees f as)++    mapFrees f (Rule i ps cs as) =+        Rule <$> mapFrees f i+             <*> mapFrees f ps <*> mapFrees f cs <*> mapFrees f as++instance Apply i => Apply (Rule i) where+    apply subst (Rule i ps cs as) =+        Rule (apply subst i) (apply subst ps) (apply subst cs) (apply subst as)++instance Sized (Rule i) where+  size (Rule _ ps cs as) = size ps + size cs + size as++------------------------------------------------------------------------------+-- Rule information split into intruder rule and protocol rules+------------------------------------------------------------------------------++-- | Rule information for protocol and intruder rules.+data RuleInfo p i =+         ProtoInfo p+       | IntrInfo i+       deriving( Eq, Ord, Show )++-- | @ruleInfo proto intr@ maps the protocol information with @proto@ and the+-- intruder information with @intr@.+ruleInfo :: (p -> c) -> (i -> c) -> RuleInfo p i -> c+ruleInfo proto _    (ProtoInfo x) = proto x+ruleInfo _     intr (IntrInfo  x) = intr x+++-- Instances+------------++instance (HasFrees p, HasFrees i) => HasFrees (RuleInfo p i) where+    foldFrees  f = ruleInfo (foldFrees f) (foldFrees f)++    mapFrees   f = ruleInfo (fmap ProtoInfo . mapFrees   f)+                            (fmap IntrInfo . mapFrees   f)++instance (Apply p, Apply i) => Apply (RuleInfo p i) where+    apply subst = ruleInfo (ProtoInfo . apply subst) (IntrInfo . apply subst)+++------------------------------------------------------------------------------+-- Protocol Rule Information+------------------------------------------------------------------------------++-- | A name of a protocol rule is either one of the special reserved rules or+-- some standard rule.+data ProtoRuleName =+         FreshRule+       | StandRule String -- ^ Some standard protocol rule+       deriving( Eq, Ord, Show, Data, Typeable )+++-- | Information for protocol rules modulo AC. The variants list the possible+-- instantiations of the free variables of the rule. The typing is interpreted+-- modulo AC; i.e., its variants were also built.+data ProtoRuleACInfo = ProtoRuleACInfo+       { _pracName         :: ProtoRuleName+       , _pracVariants     :: Disj (LNSubstVFresh)+       , _pracLoopBreakers :: [PremIdx]+       }+       deriving( Eq, Ord, Show )++-- | Information for instances of protocol rules modulo AC.+data ProtoRuleACInstInfo = ProtoRuleACInstInfo+       { _praciName         :: ProtoRuleName+       , _praciLoopBreakers :: [PremIdx]+       }+       deriving( Eq, Ord, Show )+++$(mkLabels [''ProtoRuleACInfo, ''ProtoRuleACInstInfo])+++-- Instances+------------++instance Apply ProtoRuleName where+    apply _ = id++instance HasFrees ProtoRuleName where+    foldFrees  _ = const mempty+    mapFrees   _ = pure++instance Apply PremIdx where+    apply _ = id++instance HasFrees PremIdx where+    foldFrees  _ = const mempty+    mapFrees   _ = pure++instance Apply ConcIdx where+    apply _ = id++instance HasFrees ConcIdx where+    foldFrees  _ = const mempty+    mapFrees   _ = pure++instance HasFrees ProtoRuleACInfo where+    foldFrees f (ProtoRuleACInfo na vari breakers) =+        foldFrees f na `mappend` foldFrees f vari+                       `mappend` foldFrees f breakers++    mapFrees f (ProtoRuleACInfo na vari breakers) =+        ProtoRuleACInfo na <$> mapFrees f vari <*> mapFrees f breakers++instance Apply ProtoRuleACInstInfo where+    apply _ = id++instance HasFrees ProtoRuleACInstInfo where+    foldFrees f (ProtoRuleACInstInfo na breakers) =+        foldFrees f na `mappend` foldFrees f breakers++    mapFrees f (ProtoRuleACInstInfo na breakers) =+        ProtoRuleACInstInfo na <$> mapFrees f breakers+++------------------------------------------------------------------------------+-- Intruder Rule Information+------------------------------------------------------------------------------++-- | An intruder rule modulo AC is described by its name.+data IntrRuleACInfo =+    ConstrRule String+  | DestrRule String+  | CoerceRule+  | IRecvRule+  | ISendRule+  | PubConstrRule+  | FreshConstrRule+  deriving( Ord, Eq, Show, Data, Typeable )++-- | An intruder rule modulo AC.+type IntrRuleAC = Rule IntrRuleACInfo++-- | Converts between these two types of rules, if possible.+ruleACToIntrRuleAC :: RuleAC -> Maybe IntrRuleAC+ruleACToIntrRuleAC (Rule (IntrInfo i) ps cs as) = Just (Rule i ps cs as)+ruleACToIntrRuleAC _                            = Nothing++-- | Converts between these two types of rules.+ruleACIntrToRuleAC :: IntrRuleAC -> RuleAC+ruleACIntrToRuleAC (Rule ri ps cs as) = Rule (IntrInfo ri) ps cs as++-- Instances+------------++instance Apply IntrRuleACInfo where+    apply _ = id++instance HasFrees IntrRuleACInfo where+    foldFrees _ = const mempty+    mapFrees _  = pure+++------------------------------------------------------------------------------+-- Concrete rules+------------------------------------------------------------------------------++-- | A rule modulo E is always a protocol rule. Intruder rules are specified+-- abstractly by their operations generating them and are only available once+-- their variants are built.+type ProtoRuleE  = Rule ProtoRuleName++-- | A protocol rule modulo AC.+type ProtoRuleAC = Rule ProtoRuleACInfo++-- | A rule modulo AC is either a protocol rule or an intruder rule+type RuleAC      = Rule (RuleInfo ProtoRuleACInfo IntrRuleACInfo)++-- | A rule instance module AC is either a protocol rule or an intruder rule.+-- The info identifies the corresponding rule modulo AC that the instance was+-- derived from.+type RuleACInst  = Rule (RuleInfo ProtoRuleACInstInfo IntrRuleACInfo)++-- Accessing the rule name+--------------------------++-- | Types that have an associated name.+class HasRuleName t where+  ruleName :: t -> RuleInfo ProtoRuleName IntrRuleACInfo++instance HasRuleName ProtoRuleE where+  ruleName = ProtoInfo . L.get rInfo++instance HasRuleName RuleAC where+  ruleName = ruleInfo (ProtoInfo . L.get pracName) IntrInfo . L.get rInfo++instance HasRuleName ProtoRuleAC where+  ruleName = ProtoInfo . L.get (pracName . rInfo)++instance HasRuleName IntrRuleAC where+  ruleName = IntrInfo . L.get rInfo++instance HasRuleName RuleACInst where+  ruleName = ruleInfo (ProtoInfo . L.get praciName) IntrInfo . L.get rInfo+++-- Queries+----------++-- | True iff the rule is a destruction rule.+isDestrRule :: HasRuleName r => r -> Bool+isDestrRule ru = case ruleName ru of+  IntrInfo (DestrRule _) -> True+  _                      -> False++-- | True iff the rule is a construction rule.+isConstrRule :: HasRuleName r => r -> Bool+isConstrRule ru = case ruleName ru of+  IntrInfo (ConstrRule _)  -> True+  IntrInfo FreshConstrRule -> True+  IntrInfo PubConstrRule   -> True+  IntrInfo CoerceRule      -> True+  _                        -> False++-- | True iff the rule is the special fresh rule.+isFreshRule :: HasRuleName r => r -> Bool+isFreshRule = (ProtoInfo FreshRule ==) . ruleName++-- | True iff the rule is the special learn rule.+isIRecvRule :: HasRuleName r => r -> Bool+isIRecvRule = (IntrInfo IRecvRule ==) . ruleName++-- | True iff the rule is the special knows rule.+isISendRule :: HasRuleName r => r -> Bool+isISendRule = (IntrInfo ISendRule ==) . ruleName++-- | True iff the rule is the special coerce rule.+isCoerceRule :: HasRuleName r => r -> Bool+isCoerceRule = (IntrInfo CoerceRule ==) . ruleName++-- | True if the messages in premises and conclusions are in normal form+nfRule :: Rule i -> WithMaude Bool+nfRule (Rule _ ps cs as) = reader $ \hnd ->+    all (nfFactList hnd) [ps, cs, as]+  where+    nfFactList hnd xs =+        getAll $ foldMap (foldMap (All . (\t -> nf' t `runReader` hnd))) xs++-- | True iff the rule is an intruder rule+isIntruderRule :: HasRuleName r => r -> Bool+isIntruderRule ru =+    case ruleName ru of IntrInfo _ -> True; ProtoInfo _ -> False++-- | True if the protocol rule has only the trivial variant.+isTrivialProtoVariantAC :: ProtoRuleAC -> ProtoRuleE -> Bool+isTrivialProtoVariantAC (Rule info ps as cs) (Rule _ ps' as' cs') =+    L.get pracVariants info == Disj [emptySubstVFresh]+    && ps == ps' && as == as' && cs == cs'+++-- Construction+---------------++type RuleACConstrs = Disj LNSubstVFresh++-- | Compute /some/ rule instance of a rule modulo AC. If the rule is a+-- protocol rule, then the given typing and variants also need to be handled.+someRuleACInst :: MonadFresh m+               => RuleAC+               -> m (RuleACInst, Maybe RuleACConstrs)+someRuleACInst =+    fmap extractInsts . rename+  where+    extractInsts (Rule (ProtoInfo i) ps cs as) =+      ( Rule (ProtoInfo i') ps cs as+      , Just (L.get pracVariants i)+      )+      where+        i' = ProtoRuleACInstInfo (L.get pracName i) (L.get pracLoopBreakers i)+    extractInsts (Rule (IntrInfo i) ps cs as) =+      ( Rule (IntrInfo i) ps cs as, Nothing )+++-- Unification+--------------++-- | Unify a list of @RuleACInst@ equalities.+unifyRuleACInstEqs :: [Equal RuleACInst] -> WithMaude [LNSubstVFresh]+unifyRuleACInstEqs eqs+  | all unifiable eqs = unifyLNFactEqs $ concatMap ruleEqs eqs+  | otherwise         = return []+  where+    unifiable (Equal ru1 ru2) =+         L.get rInfo ru1            == L.get rInfo ru2+      && length (L.get rPrems ru1) == length (L.get rPrems ru2)+      && length (L.get rConcs ru1) == length (L.get rConcs ru2)++    ruleEqs (Equal ru1 ru2) =+        zipWith Equal (L.get rPrems ru1) (L.get rPrems ru2) +++        zipWith Equal (L.get rConcs ru1) (L.get rConcs ru2)++-- | Are these two rule instances unifiable.+unifiableRuleACInsts :: RuleACInst -> RuleACInst -> WithMaude Bool+unifiableRuleACInsts ru1 ru2 =+    (not . null) <$> unifyRuleACInstEqs [Equal ru1 ru2]+++------------------------------------------------------------------------------+-- Fact analysis+------------------------------------------------------------------------------++-- | Globally unique facts.+--+-- A rule instance removes a fact fa if fa is in the rule's premise but not+-- in the rule's conclusion.+--+-- A fact symbol fa is globally fresh with respect to a dependency graph if+-- there are no two rule instances that remove the same fact built from fa.+--+-- We are looking for sufficient criterion to prove that a fact symbol is+-- globally fresh.+--+-- The Fr symbol is globally fresh by construction.+--+-- We have to track every creation of a globally fresh fact to a Fr fact.+--+-- (And show that the equality of of the created fact implies the equality of+-- the corresponding fresh facts. Ignore this for now by assuming that no+-- duplication happens.)+--+-- (fa(x1), fr(y1)), (fa(x2), fr(y2)) : x2 = x1 ==> y1 == y2+--+-- And ensure that every duplication is non-unifiable.+--+-- A Fr fact is described+--+-- We track which symbols are not globally fresh.+--+-- All persistent facts are not globally fresh.+--+-- Adding a rule ru.+--   All fact symbols that occur twice in the conclusion+--+-- For simplicity: globally fresh fact symbols occur at most once in premise+--   and conclusion of a rule.+--+-- A fact is removed by a rule if it occurs in the rules premise+--   1. but doesn't occur in the rule's conclusion+--   2. or does occur but non-unifiable.+--+-- We want a sufficient criterion to prove that a fact is globally unique.+--+--++------------------------------------------------------------------------------+-- Pretty-Printing+------------------------------------------------------------------------------++-- | Prefix the name if it is equal to a reserved name.+prefixIfReserved :: String -> String+prefixIfReserved n+  | n `elem` reserved  = "_" ++ n+  | "_" `isPrefixOf` n = "_" ++ n+  | otherwise          = n+  where+    reserved = ["Fresh", "irecv", "isend", "coerce", "fresh", "pub"]++prettyProtoRuleName :: Document d => ProtoRuleName -> d+prettyProtoRuleName rn = text $ case rn of+    FreshRule   -> "Fresh"+    StandRule n -> prefixIfReserved n++prettyRuleName :: (HighlightDocument d, HasRuleName (Rule i)) => Rule i -> d+prettyRuleName = ruleInfo prettyProtoRuleName prettyIntrRuleACInfo . ruleName++-- | Pretty print the rule name such that it can be used as a case name+showRuleCaseName :: HasRuleName (Rule i) => Rule i -> String+showRuleCaseName =+    render . ruleInfo prettyProtoRuleName prettyIntrRuleACInfo . ruleName++prettyIntrRuleACInfo :: Document d => IntrRuleACInfo -> d+prettyIntrRuleACInfo rn = text $ case rn of+    IRecvRule       -> "irecv"+    ISendRule       -> "isend"+    CoerceRule      -> "coerce"+    FreshConstrRule -> "fresh"+    PubConstrRule   -> "pub"+    ConstrRule name -> prefixIfReserved ('c' : name)+    DestrRule name  -> prefixIfReserved ('d' : name)++prettyNamedRule :: (HighlightDocument d, HasRuleName (Rule i))+                => d           -- ^ Prefix.+                -> (i -> d)    -- ^ Rule info pretty printing.+                -> Rule i -> d+prettyNamedRule prefix ppInfo ru =+    prefix <-> prettyRuleName ru <> colon $-$+    nest 2 (sep [ nest 1 $ ppFactsList rPrems+                , if null (L.get rActs ru)+                    then operator_ "-->"+                    else fsep [operator_ "--[", ppFacts rActs, operator_ "]->"]+                , nest 1 $ ppFactsList rConcs]) $--$+    nest 2 (ppInfo $ L.get rInfo ru)+  where+    ppList pp        = fsep . punctuate comma . map pp+    ppFacts proj     = ppList prettyLNFact $ L.get proj ru+    ppFactsList proj = fsep [operator_ "[", ppFacts proj, operator_ "]"]++prettyProtoRuleACInfo :: HighlightDocument d => ProtoRuleACInfo -> d+prettyProtoRuleACInfo i =+    (ppVariants $ L.get pracVariants i) $-$+    prettyLoopBreakers i+  where+    ppVariants (Disj [subst]) | subst == emptySubstVFresh = emptyDoc+    ppVariants substs = kwVariantsModulo "AC" $-$ prettyDisjLNSubstsVFresh substs++prettyLoopBreakers :: HighlightDocument d => ProtoRuleACInfo -> d+prettyLoopBreakers i = case breakers of+    []  -> emptyDoc+    [_] -> lineComment_ $ "loop breaker: "  ++ show breakers+    _   -> lineComment_ $ "loop breakers: " ++ show breakers+  where+    breakers = getPremIdx <$> L.get pracLoopBreakers i++prettyProtoRuleE :: HighlightDocument d => ProtoRuleE -> d+prettyProtoRuleE = prettyNamedRule (kwRuleModulo "E") (const emptyDoc)++prettyRuleAC :: HighlightDocument d => RuleAC -> d+prettyRuleAC =+    prettyNamedRule (kwRuleModulo "AC")+        (ruleInfo prettyProtoRuleACInfo (const emptyDoc))++prettyIntrRuleAC :: HighlightDocument d => IntrRuleAC -> d+prettyIntrRuleAC = prettyNamedRule (kwRuleModulo "AC") (const emptyDoc)++prettyProtoRuleAC :: HighlightDocument d => ProtoRuleAC -> d+prettyProtoRuleAC = prettyNamedRule (kwRuleModulo "AC") prettyProtoRuleACInfo++prettyRuleACInst :: HighlightDocument d => RuleACInst -> d+prettyRuleACInst = prettyNamedRule (kwInstanceModulo "AC") (const emptyDoc)++-- derived instances+--------------------++$( derive makeBinary ''Rule)+$( derive makeBinary ''ProtoRuleName)+$( derive makeBinary ''ProtoRuleACInfo)+$( derive makeBinary ''ProtoRuleACInstInfo)+$( derive makeBinary ''RuleInfo)+$( derive makeBinary ''IntrRuleACInfo)++$( derive makeNFData ''Rule)+$( derive makeNFData ''ProtoRuleName)+$( derive makeNFData ''ProtoRuleACInfo)+$( derive makeNFData ''ProtoRuleACInstInfo)+$( derive makeNFData ''RuleInfo)+$( derive makeNFData ''IntrRuleACInfo)
+ src/Theory/Model/Signature.hs view
@@ -0,0 +1,176 @@+{-# LANGUAGE DeriveDataTypeable   #-}+{-# LANGUAGE DeriveFunctor        #-}+{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE StandaloneDeriving   #-}+{-# LANGUAGE TemplateHaskell      #-}+{-# LANGUAGE TypeOperators        #-}+{-# LANGUAGE TypeSynonymInstances #-}+-- |+-- Copyright   : (c) 2010-2012 Benedikt Schmidt & Simon Meier+-- License     : GPL v3 (see LICENSE)+--+-- Maintainer  : Simon Meier <iridcode@gmail.com>+-- Portability : portable+--+-- Signatures for the terms and multiset rewriting rules used to model and+-- reason about a security protocol.+-- modulo the full Diffie-Hellman equational theory and once modulo AC.+module Theory.Model.Signature (++  -- * Signature type+    Signature(..)++  -- ** Pure signatures+  , SignaturePure+  , emptySignaturePure+  , sigpMaudeSig++  -- ** Using Maude to handle operations relative to a 'Signature'+  , SignatureWithMaude+  , toSignatureWithMaude+  , toSignaturePure+  , sigmMaudeHandle++  -- ** Pretty-printing+  , prettySignaturePure+  , prettySignatureWithMaude++  ) where++import           Data.Binary+import qualified Data.Label           as L++import           Control.Applicative+import           Control.DeepSeq++import           System.IO.Unsafe     (unsafePerformIO)++import           Term.Maude.Process   (MaudeHandle, mhFilePath, mhMaudeSig, startMaude)+import           Term.Maude.Signature (MaudeSig, enableDH, minimalMaudeSig, prettyMaudeSig)+import           Theory.Text.Pretty+++-- | A theory signature.+data Signature a = Signature+       { -- The signature of the message algebra+         _sigMaudeInfo  :: a+       }++$(L.mkLabels [''Signature])+++------------------------------------------------------------------------------+-- Pure Signatures+------------------------------------------------------------------------------++-- | A 'Signature' without an associated Maude process.+type SignaturePure = Signature MaudeSig++-- | Access the maude signature.+sigpMaudeSig:: SignaturePure L.:-> MaudeSig+sigpMaudeSig = sigMaudeInfo++-- | The empty pure signature.+emptySignaturePure :: SignaturePure+emptySignaturePure = Signature minimalMaudeSig++-- Instances+------------++deriving instance Eq       SignaturePure+deriving instance Ord      SignaturePure+deriving instance Show     SignaturePure++instance Binary SignaturePure where+    put sig =  put (L.get sigMaudeInfo sig)+    get     = Signature <$> get++instance NFData SignaturePure where+  rnf (Signature y) = rnf y++------------------------------------------------------------------------------+-- Signatures with an attached Maude process+------------------------------------------------------------------------------++-- | A 'Signature' with an associated, running Maude process.+type SignatureWithMaude = Signature MaudeHandle++-- | Access the maude handle in a signature.+sigmMaudeHandle :: SignatureWithMaude L.:-> MaudeHandle+sigmMaudeHandle = sigMaudeInfo++-- | Ensure that maude is running and configured with the current signature.+toSignatureWithMaude :: FilePath            -- ^ Path to Maude executable.+                     -> SignaturePure+                     -> IO (SignatureWithMaude)+toSignatureWithMaude maudePath sig = do+    hnd <- startMaude maudePath (L.get sigMaudeInfo sig)+    return $ sig { _sigMaudeInfo = hnd }+++-- | The pure signature of a 'SignatureWithMaude'.+toSignaturePure :: SignatureWithMaude -> SignaturePure+toSignaturePure sig = sig { _sigMaudeInfo = mhMaudeSig $ L.get sigMaudeInfo sig }++{- TODO: There should be a finalizer in place such that as soon as the+   MaudeHandle is garbage collected, the appropriate command is sent to Maude++  The code below is a crutch and leads to unnecessary complication.+++-- | Stop the maude process. This operation is unsafe, as there still might be+-- thunks that rely on the MaudeHandle to refer to a running Maude process.+unsafeStopMaude :: SignatureWithMaude -> IO (SignaturePure)+unsafeStopMaude = error "unsafeStopMaude: implement"++-- | Run an IO action with maude running and configured with a specific+-- signature. As there must not be any part of the return value that depends+-- on unevaluated calls to the Maude process provided to the inner IO action.+unsafeWithMaude :: FilePath      -- ^ Path to Maude executable+                -> SignaturePure -- ^ Signature to use+                -> (SignatureWithMaude -> IO a) -> IO a+unsafeWithMaude maudePath sig  =+    bracket (startMaude maudePath sig) unsafeStopMaude++-}++-- Instances+------------++instance Eq SignatureWithMaude where+  x == y = toSignaturePure x == toSignaturePure y++instance Ord SignatureWithMaude where+  compare x y = compare (toSignaturePure x) (toSignaturePure y)++instance Show SignatureWithMaude where+  show = show . toSignaturePure++instance Binary SignatureWithMaude where+    put sig@(Signature maude) = do+        put (mhFilePath maude)+        put (toSignaturePure sig)+    -- FIXME: reload the right signature+    get = unsafePerformIO <$> (toSignatureWithMaude <$> get <*> get)++instance NFData SignatureWithMaude where+  rnf (Signature _maude) = ()++------------------------------------------------------------------------------+-- Pretty-printing+------------------------------------------------------------------------------++-- | Pretty-print a signature with maude.+prettySignaturePure :: HighlightDocument d => SignaturePure -> d+prettySignaturePure sig = vsep $ map combine $+    -- FIXME: Print Maude signature completely, this is only used for+    -- intruder-variants for now.+    [ ("builtin", text "diffie-hellman" ) | enableDH . L.get sigpMaudeSig $ sig ]+  where+    combine (header, d) = fsep [keyword_ header <> colon, nest 2 d]++-- | Pretty-print a pure signature.+prettySignatureWithMaude :: HighlightDocument d => SignatureWithMaude -> d+prettySignatureWithMaude sig =+    prettyMaudeSig $ mhMaudeSig $ L.get sigmMaudeHandle sig+
− src/Theory/Parser.hs 
@@ -1,860 +0,0 @@-{-# LANGUAGE TupleSections #-}--- |--- Copyright   : (c) 2010-2012 Simon Meier, Benedikt Schmidt--- License     : GPL v3 (see LICENSE)--- --- Maintainer  : Simon Meier <iridcode@gmail.com>--- Portability : portable------ Parsing protocol theories.-module Theory.Parser (-    parseOpenTheory-  , parseOpenTheoryString-  , parseProofMethod-  , parseLemma-  , parseIntruderRulesDH-  ) where--import           Prelude hiding (id, (.))--import           Data.Char     (toUpper, isUpper, isDigit)-import           Data.Foldable (asum)-import           Data.Label-import qualified Data.Set                                 as S-import qualified Data.Map                                 as M-import           Data.Monoid-import qualified Data.ByteString.Char8                    as BC--import           Control.Monad-import           Control.Applicative hiding (empty, many, optional)-import           Control.Category--import           Text.Parsec.Pos-import           Text.Parsec hiding (token, (<|>), string )-import qualified Text.Parsec as P--import           Theory.Lexer -                   ( Keyword(..), TextType(..), runAlex, AlexPosn(..)-                   , alexGetPos, alexMonadScan-                   )-import           Term.SubtermRule-import           Term.Substitution--import Text.PrettyPrint.Class (render)--import Theory----------------------------------------------------------------------------------- Specializing Parsec to our needs----------------------------------------------------------------------------------- Scanner--------------- | The tokens delivered by our Alex based scanner-type Token = (SourcePos, Keyword)---- | Scan a string using the given filename in the error messages.------ NOTE: Lexical errors are thrown using 'error'.-scanString :: FilePath -> String -> [Token]-scanString filename s = -  case runAlex s gatherUntilEOF of-    Left err  -> error err-    Right kws -> kws-  where-  gatherUntilEOF = do-    AlexPn _ line col <- alexGetPos-    let pos = newPos filename line col-    k <- alexMonadScan-    case k of -      EOF -> return [(pos,EOF)]-      _   -> do kws <- gatherUntilEOF-                return $ (pos,k) : kws---- Parser-------------- | A parser for a stream of tokens.-type Parser a = Parsec [Token] MaudeSig a---- | Parse a token based on the acceptance condition-token :: (Keyword -> Maybe a) -> Parser a-token p = P.token (show . snd) fst (p . snd)---- | Parse a term.-kw :: Keyword -> Parser ()-kw t = token check-  where -  check t' | t == t' = Just () | otherwise = Nothing---- | Parse content between keywords.-betweenKWs :: Keyword -> Keyword -> Parser a -> Parser a-betweenKWs l r = between (kw l) (kw r)--{---- | Between braces.-braced :: Parser a -> Parser a-braced = betweenKWs LBRACE RBRACE--}---- | Between parentheses.-parens :: Parser a -> Parser a-parens = betweenKWs LPAREN RPAREN---- | Between single quotes.-singleQuoted :: Parser a -> Parser a-singleQuoted = betweenKWs SQUOTE SQUOTE---- | Between double quotes.-doubleQuoted :: Parser a -> Parser a-doubleQuoted = betweenKWs DQUOTE DQUOTE---- | Parse an identifier as a string-identifier :: Parser String-identifier = token extract-  where extract (IDENT name) -         -- don't allow certain reserved words as identifiers-         | not (name `elem` ["in","let","rule"]) = Just name-        extract _                                = Nothing---- | Parse an identifier as a string-string :: String -> Parser ()-string cs = token extract-  where extract (IDENT name) | cs == name = Just ()-        extract _                         = Nothing---- | Parse a sequence of fixed strings.-strings :: [String] -> Parser ()-strings = mapM_ string---- | Parse an integer.-integer :: Parser Int-integer = do i <- identifier-             guard (all isDigit i)-             return (read i)---- | A comma separated list of elements.-commaSep :: Parser a -> Parser [a]-commaSep = (`sepBy` kw COMMA)--{---- | A comma separated non-empty list of elements.-commaSep1 :: Parser a -> Parser [a]-commaSep1 = (`sepBy1` kw COMMA)--}---- | Parse a list of items '[' item ',' ... ',' item ']'-list :: Parser a -> Parser [a]-list p = kw LBRACKET *> commaSep p <* kw RBRACKET---- | A formal comment; i.e., (header, body)-formalComment :: Parser (String, String)-formalComment =-    (,) <$> text begin -        <*> (concat <$> many (text content) <* text end)-  where-    text f = token (\t -> case t of TEXT ty -> f ty; _ -> mzero)-    begin (TextBegin str)     = return str-    begin _                   = mzero-    content (TextContent str) = return str-    content _                 = mzero-    end (TextEnd)             = return ()-    end _                     = mzero------------------------------------------------------------------------------------ Lexing and parsing theory files and proof methods----------------------------------------------------------------------------------- | Parser a file.-parseFile :: Parser a -> FilePath -> IO a-parseFile parser f = do-  s <- readFile f-  case runParser parser minimalMaudeSig f (scanString f s) of-    Right p -> return p-    Left err -> error $ show err---- | Parse a security protocol theory file.-parseOpenTheory :: [String] -- ^ Defined flags-                -> FilePath -> IO OpenTheory-parseOpenTheory flags = parseFile (theory flags)---- | Parse DH intruder rules.-parseIntruderRulesDH :: FilePath -> IO [IntrRuleAC]-parseIntruderRulesDH = parseFile (setState dhMaudeSig >> many intrRule)---- | Parse a security protocol theory file.--- TODO: This function seems to parse a string, not a file from a file path?-parseProofMethod :: FilePath -> Either ParseError ProofMethod-parseProofMethod = -    runParser proofMethod minimalMaudeSig dummySource . scanString dummySource-  where -    dummySource = "<interactive>"---- | Parse a security protocol theory from a string.-parseOpenTheoryString :: [String]  -- ^ Defined flags.-                      -> String -> Either ParseError OpenTheory-parseOpenTheoryString flags = parseFromString (theory flags)---- | Parse a lemma for an open theory from a string.-parseLemma :: String -> Either ParseError (Lemma ProofSkeleton)-parseLemma = parseFromString lemma---- | Run a given parser on a given string.-parseFromString :: Parser a -> String -> Either ParseError a-parseFromString parser =-    runParser parser minimalMaudeSig dummySource . scanString dummySource-  where-    dummySource = "<interactive>"----------------------------------------------------------------------------------- Parsing Terms----------------------------------------------------------------------------------{--BNF:  Not completely up to date...--theory      := 'theory' ident 'begin' protocol 'end'-protocol    := rules-rules       := rule | rule rules-intrrule    := ident '[' intrinfo ']' ':' terms '-->' terms-intrinfo    := 'Destr' | 'Constr'-protorule   := ident ':' factList '-->' factList-factList    := '[' [facts] ']'-facts       := fact | fact ',' facts-protoFact   := ident '(' terms ')'-terms       := term | term ',' terms -term        := lit | application | '<' term ',' terms '>'  -- right assoc pairing-application := ident '(' terms ')'-lit        := ident | '\'' ident '\''-ident       := <a-zA-Z> (<a-zA-Z0-9-_)---// example protocol rule--  Init_1: -    [ Pub(I), Pub(R), Fresh(ni) ]-    -->-    [ Init_1(I,R,ni), Send(encA(pk(R), <I,R,ni>)) ]--// example intruder rule-  -  Exp [Constr]:-    [ (x^_((x1*x2))), ((x3*x1)*_x4) ]-    -->-    [ (x^(x3*_((x4*x2)))) ]---}----------------------------------------------------------------------------------- Parsing Terms----------------------------------------------------------------------------------- | Parse an identifier possibly indexed with a number.-indexedIdentifier :: Parser (String, Integer)-indexedIdentifier = do-    (,) <$> identifier-        <*> option 0 (try (kw DOT *> (fromIntegral <$> integer)))---- | Parse a logical variable with the given sorts allowed.-sortedLVar :: [LSort] -> Parser LVar-sortedLVar ss = -    asum $ map (try . mkSuffixParser) ss ++ map mkPrefixParser ss-  where-    mkSuffixParser s = do-        (n, i) <- indexedIdentifier-        kw COLON-        string (sortSuffix s)-        return (LVar n s i)--    mkPrefixParser s = do-        case s of-          LSortMsg   -> pure ()-          LSortPub   -> kw DOLLAR-          LSortFresh -> kw TILDE-          LSortNode  -> kw SHARP-          LSortMSet  -> kw PERCENT-        (n, i) <- indexedIdentifier-        return (LVar n s i)---- | An arbitrary logical variable.-lvar :: Parser LVar-lvar = sortedLVar [minBound..]---- | Parse a non-node variable.-msgvar :: Parser LVar-msgvar = sortedLVar [LSortFresh, LSortPub, LSortMsg, LSortMSet]---- | Parse a graph node variable.-nodevar :: Parser NodeId-nodevar = asum -  [ sortedLVar [LSortNode]-  , (\(n, i) -> LVar n LSortNode i) <$> indexedIdentifier ]-  <?> "node"---- | Parse an lit with logical variables.-llit :: Parser LNTerm-llit = asum-    [ freshTerm  <$> try (kw TILDE *> singleQuoted identifier) <?> "fresh name"-    , pubTerm    <$> singleQuoted identifier                  <?> "public name"-    , varTerm    <$> msgvar-    ]---- | Lookup the arity of a non-ac symbol. Fails with a sensible error message--- if the operator is not known.-lookupNonACArity :: String -> Parser Int-lookupNonACArity op = do-    maudeSig <- getState-    case lookup (BC.pack op) (S.toList $ allFunctionSymbols maudeSig) of-        Nothing -> fail $ "unknown operator `" ++ op ++ "'"-        Just k  -> return k---- | Parse an n-ary operator application for arbitrary n.-naryOpApp :: Ord l => Parser (Term l) -> Parser (Term l)-naryOpApp plit = do-    op <- identifier-    k  <- lookupNonACArity op-    ts <- parens $ if k == 1-                     then return <$> tupleterm plit-                     else sepBy (multterm plit) (kw COMMA)-    let k' = length ts-    when (k /= k') $-        fail $ "operator `" ++ op ++"' has arity " ++ show k ++-               ", but here it is used with arity " ++ show k'-    return $ fAppNonAC (BC.pack op, k') ts---- | Parse a binary operator written as @op{arg1}arg2@.-binaryAlgApp :: Ord l => Parser (Term l) -> Parser (Term l)-binaryAlgApp plit = do-    op <- identifier-    k <- lookupNonACArity op-    arg1 <- kw LBRACE *> tupleterm plit <* kw RBRACE-    arg2 <- term plit-    when (k /= 2) $ fail $ -      "only operators of arity 2 can be written using the `op{t1}t2' notation"-    return $ fAppNonAC (BC.pack op, 2) [arg1, arg2]---- | Parse a term.-term :: Ord l => Parser (Term l) -> Parser (Term l)-term plit = asum-    [ pairing       <?> "pairs"-    , parens (multterm plit)-    , string "1" *> pure fAppOne-    , application <?> "function application"-    , nullaryApp-    , plit  -    ]-    <?> "term"-  where-    application = asum $ map (try . ($ plit)) [naryOpApp, binaryAlgApp]-    pairing = kw LESS *> tupleterm plit <* kw GREATER-    nullaryApp = do-      maudeSig <- getState-      asum [ try (string (BC.unpack sym)) *> pure (fApp (NonAC (sym,0)) [])-           | (sym,0) <- S.toList $ allFunctionSymbols maudeSig ]---- | A left-associative sequence of exponentations.-expterm :: Ord l => Parser (Term l) -> Parser (Term l)-expterm plit = chainl1 (term plit) ((\a b -> fAppExp (a,b)) <$ kw HAT)---- | A left-associative sequence of multiplications.-multterm :: Ord l => Parser (Term l) -> Parser (Term l)-multterm plit = do-    dh <- enableDH <$> getState-    if dh -- if DH is not enabled, do not accept 'multterm's and 'expterm's-        then chainl1 (expterm plit) ((\a b -> fAppMult [a,b]) <$ kw STAR)-        else term plit---- | A right-associative sequence of tuples.-tupleterm :: Ord l => Parser (Term l) -> Parser (Term l)-tupleterm plit = chainr1 (multterm plit) ((\a b -> fAppPair (a,b))<$ kw COMMA)---- | Parse a fact.-fact :: Ord l => Parser (Term l) -> Parser (Fact (Term l))-fact plit = -    do multi <- option Linear (kw BANG *> pure Persistent)-       i     <- identifier-       case i of-         []                -> fail "empty identifier"-         (c:_) | isUpper c -> return ()-               | otherwise -> fail "facts must start with upper-case letters"-       ts    <- parens (sepBy (multterm plit) (kw COMMA))-       mkProtoFact multi i ts-    <?> "protocol fact"-  where-    singleTerm _ constr [t] = return $ constr t-    singleTerm f _      ts  = fail $ "fact '" ++ f ++ "' used with arity " ++-                                     show (length ts) ++ " instead of arity one"--    mkProtoFact multi f = case map toUpper f of-      "OUT" -> singleTerm f outFact -      "IN"  -> singleTerm f inFact-      "KU"  -> return . Fact KUFact-      "KD"  -> return . Fact KDFact-      "DED" -> return . Fact DedFact-      "FR"  -> singleTerm f freshFact-      _     -> return . protoFact multi f------------------------------------------------------------------------------------ Parsing Rules----------------------------------------------------------------------------------- | Parse a "(modulo ..)" information.-modulo :: String -> Parser ()-modulo thy = parens $ strings ["modulo", thy]--moduloE, moduloAC :: Parser ()-moduloE  = modulo "E"-moduloAC = modulo "AC"--{---- | Parse a typing assertion modulo E.-typeAssertions :: Parser TypingE-typeAssertions = fmap TypingE $-    do try (strings ["type", "assertions"])-       optional moduloE-       kw COLON-       many1 ((,) <$> (try (msgvar <* kw COLON))-                  <*> ( commaSep1 (try $ multterm llit) <|> -                        (kw MINUS *> pure [])-                      )-             ) -    <|> pure []--}---- | Parse a protocol rule. For the special rules 'Reveal_fresh', 'Fresh',--- 'Knows', and 'Learn' no rule is returned as the default theory already--- contains them.-protoRule :: Parser (ProtoRuleE)-protoRule = do-    name  <- try (string "rule" *> optional moduloE *> identifier <* kw COLON) -    subst <- option emptySubst letBlock-    (ps,as,cs) <- genericRule-    return $ apply subst $ Rule (StandRule name) ps cs as---- | Parse a let block with bottom-up application semantics.-letBlock :: Parser LNSubst-letBlock = do-    toSubst <$> (string "let" *> many1 definition <* string "in")-  where-    toSubst = foldr1 compose . map (substFromList . return)-    definition = (,) <$> (sortedLVar [LSortMsg] <* kw EQUAL) <*> multterm llit---- | Parse an intruder rule.-intrRule :: Parser IntrRuleAC-intrRule = do-    info <- try (string "rule" *> moduloAC *> intrInfo <* kw COLON) -    (ps,as,cs) <- genericRule-    return $ Rule info ps cs as-  where-    intrInfo = do-        name <- identifier-        case name of-          'c':cname -> return $ ConstrRule cname-          'd':dname -> return $ DestrRule dname-          _         -> fail $ "invalid intruder rule name '" ++ name ++ "'"--genericRule :: Parser ([LNFact], [LNFact], [LNFact])-genericRule = -    (,,) <$> list (fact llit) -         <*> ((pure [] <* kw LONGRIGHTARROW) <|>-              (kw MINUS *> kw MINUS *> list (fact llit) <* kw RIGHTARROW))-         <*> list (fact llit)--{---- | Add facts to a rule.-addFacts :: String        -- ^ Command to be used: add_concs, add_prems-         -> Parser (String, [LNFact])-addFacts cmd = -    (,) <$> (string cmd *> identifier <* kw COLON) <*> commaSep1 fact--}----------------------------------------------------------------------------------- Parsing transfer notation---------------------------------------------------------------------------------{---- | Parse an lit with strings for both constants as well as variables.-tlit :: Parser TTerm-tlit = asum-    [ constTerm <$> singleQuoted identifier-    , varTerm  <$> identifier-    ]---- | Parse a single transfer.-transfer :: Parser Transfer-transfer = do-  tf <- (\l -> Transfer l Nothing Nothing) <$> identifier <* kw DOT-  (do right <- kw RIGHTARROW *> identifier <* kw COLON-      desc <- transferDesc-      return $ tf { tfRecv = Just (desc right) }-   <|>-   do right <- kw LEFTARROW *> identifier <* kw COLON-      descr <- transferDesc-      (do left <- try $ identifier <* kw LEFTARROW <* kw COLON-          descl <- transferDesc-          return $ tf { tfSend = Just (descr right)-                      , tfRecv = Just (descl left) }-       <|>-       do return $ tf { tfSend = Just (descr right) }-       )-   <|>-   do left <- identifier-      (do kw RIGHTARROW-          (do right <- identifier <* kw COLON-              desc <- transferDesc-              return $ tf { tfSend = Just (desc left)-                          , tfRecv = Just (desc right) }-           <|>-           do descl <- kw COLON *> transferDesc-              (do right <- kw RIGHTARROW *> identifier <* kw COLON-                  descr <- transferDesc-                  return $ tf { tfSend = Just (descl left)-                              , tfRecv = Just (descr right) }-               <|>-               do return $ tf { tfSend = Just (descl left) }-               )-           )-       <|>-       do kw LEFTARROW-          (do desc <- kw COLON *> transferDesc-              return $ tf { tfRecv = Just (desc left) }-           <|>-           do right <- identifier <* kw COLON-              desc <- transferDesc-              return $ tf { tfSend = Just (desc right)-                          , tfRecv = Just (desc left) }-           )-       )-    ) -  where-    transferDesc = do-        ts        <- tupleterm tlit-        moreConcs <- (string "note" *> many1 (try $ fact tlit))-                     <|> pure []-        types     <- typeAssertions-        return $ \a -> TransferDesc a ts moreConcs types----- | Parse a protocol in transfer notation-transferProto :: Parser [ProtoRuleE]-transferProto = do-    name <- string "anb" *> kw MINUS *> string "proto" *> identifier -    braced (convTransferProto name <$> abbrevs <*> many1 transfer)-  where-    abbrevs = (string "let" *> many1 abbrev) <|> pure []-    abbrev = (,) <$> try (identifier <* kw EQUAL) <*> multterm tlit ---}----------------------------------------------------------------------------------- Parsing Proofs---------------------------------------------------------------------------------{---- | Parse a node premise.-nodePrem :: Parser NodePrem-nodePrem = NodePrem <$> parens ((,) <$> nodevar <*> (kw COMMA *> integer))---- | Parse a node conclusion.-nodeConc :: Parser NodeConc-nodeConc = NodeConc <$> parens ((,) <$> nodevar <*> (kw COMMA *> integer))--}----- | Parse the @\@@ requires operator.-actionOp :: Parser ()-actionOp = try (kw AT)---- | Parse the @<@ temporal less operator.-edgeOp :: Parser ()-edgeOp = try (kw GREATER *> kw RIGHTARROW)---- | Parse the @<@ temporal less operator.-lessOp :: Parser ()-lessOp = try (kw LESS)---- | Parse the @=@ equal operator.-equalOp :: Parser ()-equalOp = kw APPROX <|> kw EQUAL---- | Parse the @--|@ deduced before operator.-dedBeforeOp :: Parser ()-dedBeforeOp = try (kw MINUS *> kw MINUS *> kw MID)--{---- | Parse the @~~>@ chain operator.-chainOp :: Parser ()-chainOp = kw TILDE *> kw TILDE *> kw TILDE *> kw GREATER--}---- | Parse a goal.-goal :: Parser Goal-goal = fail "SM: reimplement goal parsing" {- asum -  [ splitGoal-  , premiseGoal-  , chainGoal-  ]-  where-    premiseGoal = try $ do-        v  <- nodevar-        i  <- brackets integer <* requiresOp-        fa <- fact llit-        return $ PremiseGoal fa (NodePrem (v, i))--    chainGoal = ChainGoal -        <$> (try $ term llit <* kw COLON)-        <*> (Chain <$> (nodeConc <* chainOp) <*> nodePrem)--    splitGoal = do-        split <- (string "splitEqsOn"    *> pure SplitEqs) <|>-                 (string "splitTypingOn" *> pure SplitTyping)-        SplitGoal split <$> parens integer--}---- | Parse a proof method.-proofMethod :: Parser ProofMethod-proofMethod = optional (kw BANG) *> asum-  [ string "sorry"         *> pure (Sorry "not yet proven")-  , string "simplify"      *> pure Simplify-  , string "solve"         *> (SolveGoal <$> parens goal)-  , string "contradiction" *> pure (Contradiction Nothing)-  ]---- | Parse a proof skeleton.-proofSkeleton :: Parser ProofSkeleton-proofSkeleton = -    finalProof <|> interProof-  where-    finalProof = do-        method <- string "by" *> proofMethod-        return (LNode (ProofStep method ()) M.empty)--    interProof = do-        method <- proofMethod-        cases  <- (sepBy oneCase (string "next") <* string "qed") <|> -                  ((return . ("",)) <$> proofSkeleton           )-        return (LNode (ProofStep method ()) (M.fromList cases))--    oneCase = (,) <$> (string "case" *> identifier) <*> proofSkeleton ----------------------------------------------------------------------------------- Parsing Formulas and Lemmas----------------------------------------------------------------------------------- | Parse an atom with possibly bound logical variables.-blatom :: Parser BLAtom-blatom = (fmap (fmapTerm (fmap Free))) <$> asum-  [ flip Action <$> try (fact llit <* actionOp) <*> nodevarTerm      <?> "action"-  , Less        <$> try (nodevarTerm <* lessOp)    <*> nodevarTerm   <?> "less"-  , DedBefore   <$> try (term llit <* dedBeforeOp) <*> nodevarTerm   <?> "deduced before"-  , EdgeA       <$> try (nodeConc <* edgeOp)       <*> nodePrem      <?> "edge"-  , EqE         <$> try (multterm llit <* equalOp) <*> multterm llit <?> "term equality"-  , EqE         <$>     (nodevarTerm  <* equalOp)  <*> nodevarTerm   <?> "node equality"-  ]-  where -    nodevarTerm = (lit . Var) <$> nodevar-    nodePrem = annNode PremIdx-    nodeConc = annNode ConcIdx-    annNode mkAnn = parens ((,) <$> (nodevarTerm <* kw COMMA) -                                <*> (mkAnn <$> integer))---- | Parse an atom of a formula.-fatom :: Parser (LFormula Name)-fatom = asum-  [ pure lfalse <* string "F"-  , pure ltrue  <* string "T"-  , Ato <$> try blatom-  , quantification-  , parens iff-  ]-  where-    quantification = do-        q <- (pure forall <* (kw FORALL <|> string "All")) <|>-             (pure exists <* (kw EXISTS <|> string "Ex") )-        vs <- many1 lvar <* kw DOT-        f  <- iff-        return $ foldr (hinted q) f vs--    hinted :: ((String, LSort) -> LVar -> a) -> LVar -> a-    hinted f v@(LVar n s _) = f (n,s) v------ | Parse a negation.-negation :: Parser (LFormula Name)-negation = ((kw LNOT <|> string "not") *> (Not <$> fatom)) <|> fatom---- | Parse a left-associative sequence of conjunctions.-conjuncts :: Parser (LFormula Name)-conjuncts = chainl1 negation ((.&&.) <$ (kw LAND <|> kw AND))---- | Parse a left-associative sequence of disjunctions.-disjuncts :: Parser (LFormula Name)-disjuncts = chainl1 conjuncts ((.||.) <$ (kw LOR <|> kw MID))---- | An implication.-imp :: Parser (LFormula Name)-imp = do-  lhs <- disjuncts-  asum [ try (kw EQUAL *> kw EQUAL *> kw GREATER) *> -             ((lhs .==>.) <$> imp)-       , pure lhs ]---- | An logical equivalence.-iff :: Parser (LFormula Name)-iff = do-  lhs <- imp-  asum [ try (kw LESS *> kw EQUAL *> kw GREATER) *> -             ((lhs .<=>.) <$> imp)-       , pure lhs ]---- | Parse a 'LemmaAttribute'.-lemmaAttribute :: Parser LemmaAttribute-lemmaAttribute = asum-  [ string "typing"    *> pure TypingLemma-  , string "reuse"     *> pure ReuseLemma-  , string "invariant" *> pure InvariantLemma-  ]---- | Parse a 'TraceQuantifier'.-traceQuantifier :: Parser TraceQuantifier-traceQuantifier = asum-  [ string "all"    *> kw MINUS *> string "traces" *> pure AllTraces-  , string "exists" *> kw MINUS *> string "trace"  *> pure ExistsTrace-  ]---- | Parse a lemma.-lemma :: Parser (Lemma ProofSkeleton)-lemma = skeletonLemma <$> (string "lemma" *> optional moduloE *> identifier) -                      <*> (option [] $ list lemmaAttribute)-                      <*> (kw COLON *> option AllTraces traceQuantifier)-                      <*> doubleQuoted iff-                      <*> (proofSkeleton <|> pure (unproven ()))----- | Parse a globally fresh 'FactTag' written as--- ---     fresh proto/2--globallyFresh :: Parser (S.Set FactTag)-globallyFresh = -    string "unique_insts" *> kw COLON *> -        (S.fromList <$> sepBy1 factSymbol (kw COMMA))-  where-    factSymbol = -        ProtoFact Linear <$> identifier <*> (kw SLASH *> integer)--builtins :: Parser ()-builtins =-    string "builtins" *> kw COLON *> sepBy1 builtinTheory (kw COMMA) *> pure ()-  where-    extendSig msig = modifyState (`mappend` msig)-    builtinTheory = asum-      [ try (string "diffie"     *> kw MINUS *> string "hellman")-          *> extendSig dhMaudeSig-      , try (string "symmetric"  *> kw MINUS *> string "encryption")-          *> extendSig symEncMaudeSig-      , try (string "asymmetric" *> kw MINUS *> string "encryption")-          *> extendSig asymEncMaudeSig-      , try (string "signing")-          *> extendSig signatureMaudeSig-      , string "hashing"-          *> extendSig hashMaudeSig-      ]--functions :: Parser ()-functions =-    string "functions" *> kw COLON *> sepBy1 functionSymbol (kw COMMA) *> pure ()-  where-    functionSymbol = do-        funsym <- (,) <$> (BC.pack <$> identifier) <*> (kw SLASH *> integer)-        sig <- getState-        case lookup (fst funsym) (S.toList $ allFunctionSymbols sig) of-          Just k | k /= snd funsym ->-            fail $ "conflicting arities " ++ -                   show k ++ " and " ++ show (snd funsym) ++ -                   " for `" ++ BC.unpack (fst funsym)-          _ -> setState (addFunctionSymbol funsym sig)--equations :: Parser ()-equations =-    string "equations" *> kw COLON *> sepBy1 equation (kw COMMA) *> pure ()-  where-    equation = do-        rrule <- RRule <$> term llit <*> (kw EQUAL *> term llit)-        case rRuleToStRule rrule of-          Just str ->-              modifyState (addStRule str)-          Nothing  ->-              fail $ "Not a subterm rule: " ++ show rrule----------------------------------------------------------------------------------- Parsing Theories------------------------------------------------------------------------------------ | Parse a theory.-theory :: [String]   -- ^ Defined flags.-       -> Parser OpenTheory-theory flags0 = do-    string "theory"-    thyId <- identifier-    string "begin" -        *> addItems (S.fromList flags0) (set thyName thyId defaultOpenTheory) -        <* string "end"-  where-    addItems :: S.Set String -> OpenTheory -> Parser OpenTheory-    addItems flags thy = asum-      [ do fresh <- globallyFresh-           addItems flags $ -               modify (sigpUniqueInsts . thySignature) (S.union fresh) thy-      , do builtins-           msig <- getState-           addItems flags $ set (sigpMaudeSig . thySignature) msig thy-      , do functions-           msig <- getState-           addItems flags $ set (sigpMaudeSig . thySignature) msig thy-      , do equations-           msig <- getState-           addItems flags $ set (sigpMaudeSig . thySignature) msig thy---      , do thy' <- foldM liftedAddProtoRule thy =<< transferProto---           addItems flags thy'-      , do thy' <- liftedAddLemma thy =<< lemma-           addItems flags thy'-      , do ru <- protoRule-           thy' <- liftedAddProtoRule thy ru-           addItems flags thy'-      , do r <- intrRule-           addItems flags (addIntrRuleACs [r] thy)-      , do c <- formalComment-           addItems flags (addFormalComment c thy)-      , do ifdef flags thy-      , do define flags thy-      , do return thy-      ]--    define :: S.Set String -> OpenTheory -> Parser OpenTheory-    define flags thy = do-       flag <- try (kw SHARP *> string "define") *> identifier-       addItems (S.insert flag flags) thy--    ifdef :: S.Set String -> OpenTheory -> Parser OpenTheory-    ifdef flags thy = do-       flag <- try (kw SHARP *> string "ifdef") *> identifier-       thy' <- addItems flags thy-       try (kw SHARP *> string "endif")-       if flag `S.member` flags-         then addItems flags thy'-         else addItems flags thy--    liftedAddProtoRule thy ru = case addProtoRule ru thy of-        Just thy' -> return thy'-        Nothing   -> fail $ "duplicate rule: " ++ render (prettyRuleName ru)--    liftedAddLemma thy l = case addLemma l thy of-        Just thy' -> return thy'-        Nothing   -> fail $ "duplicate lemma: " ++ get lName l
− src/Theory/Pretty.hs 
@@ -1,109 +0,0 @@--- |--- Copyright   : (c) 2011 Simon Meier--- License     : GPL v3 (see LICENSE)--- --- Maintainer  : Simon Meier <iridcode@gmail.com>--- Portability : portable------ General support for pretty printing theories.-module Theory.Pretty (-  -- * General highlighters-    module Text.PrettyPrint.Highlight--  -- * Comments-  , lineComment-  , multiComment--  , lineComment_-  , multiComment_--  -- * Keywords-  , kwTheoryHeader-  , kwEnd   -  , kwModulo-  , kwBy-  , kwCase-  , kwNext-  , kwQED--  -- ** Composed forms-  , kwLemmaModulo-  , kwRuleModulo-  , kwInstanceModulo-  , kwVariantsModulo-  , kwTypesModulo--  -- * Operators-  , opProvides-  , opRequires-  , opAction-  , opPath-  , opLess-  , opEqual-  , opDedBefore-  , opEdge--  ) where--import Text.PrettyPrint.Highlight----------------------------------------------------------------------------------- Comments---------------------------------------------------------------------------------lineComment :: HighlightDocument d => d -> d-lineComment d = comment $ text "//" <-> d--lineComment_ :: HighlightDocument d => String -> d-lineComment_ = lineComment . text--multiComment :: HighlightDocument d => d -> d-multiComment d = comment $ fsep [text "/*", d, text "*/"]--multiComment_ :: HighlightDocument d => [String] -> d-multiComment_ ls = comment $ fsep [text "/*", vcat $ map text ls, text "*/"]----------------------------------------------------------------------------------- Keywords---------------------------------------------------------------------------------kwTheoryHeader :: HighlightDocument d => String -> d-kwTheoryHeader name = keyword_ "theory" <-> text name <-> keyword_ "begin"--kwEnd, kwBy, kwCase, kwNext, kwQED :: HighlightDocument d => d-kwEnd    = keyword_ "end"-kwBy     = keyword_ "by"-kwCase   = keyword_ "case"-kwNext   = keyword_ "next"-kwQED    = keyword_ "qed"--kwModulo :: HighlightDocument d-         => String  -- ^ What-         -> String  -- ^ modulo theory-         -> d-kwModulo what thy = keyword_ what <-> parens (keyword_ "modulo" <-> text thy)--kwLemmaModulo, kwRuleModulo, kwInstanceModulo, kwTypesModulo, kwVariantsModulo-  :: HighlightDocument d => String -> d-kwLemmaModulo    = kwModulo "lemma"-kwRuleModulo     = kwModulo "rule"-kwInstanceModulo = kwModulo "instance"-kwTypesModulo    = kwModulo "type assertions"-kwVariantsModulo = kwModulo "variants"------------------------------------------------------------------------------------ Operators---------------------------------------------------------------------------------opProvides, opRequires, opAction, opPath, opLess, opEqual, opDedBefore, opEdge-  :: HighlightDocument d => d-opProvides  = operator_ ":>"-opRequires  = operator_ "<:"-opAction    = operator_ "@"-opPath      = operator_ ">+>"-opLess      = operator_ "<"-opEqual     = operator_ "="-opDedBefore = operator_ "--|"-opEdge      = operator_ ">->"-
src/Theory/Proof.hs view
@@ -1,8 +1,10 @@-{-# LANGUAGE TemplateHaskell, TupleSections #-}+{-# LANGUAGE BangPatterns    #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections   #-} -- | -- Copyright   : (c) 2010-2012 Simon Meier & Benedikt Schmidt -- License     : GPL v3 (see LICENSE)--- +-- -- Maintainer  : Simon Meier <iridcode@gmail.com> -- Portability : GHC only --@@ -13,10 +15,7 @@   , mergeMapsWith    -- * Types-  , Contradiction(..)-  , ProofMethod(..)   , ProofStep(..)-  , CaseName   , Proof    -- ** Paths inside proofs@@ -31,17 +30,10 @@   , ProofStatus(..)   , proofStepStatus -  , cutOnAttackDFS-  , cutOnAttackBFS-   -- ** Unfinished proofs   , sorry   , unproven -  -- ** Proof methods-  , execProofMethod-  , possibleProofMethods-   -- ** Incremental proof construction   , IncrementalProof   , Prover@@ -52,16 +44,17 @@   , tryProver   , sorryProver   , oneStepProver-  , autoProver-  , boundProver   , focus   , checkAndExtendProver   , replaceSorryProver-  , contradictionAndClauseProver+  , contradictionProver +  -- ** Explicit representation of a fully automatic prover+  , SolutionExtractor(..)+  , AutoProver(..)+  , runAutoProver+   -- ** Pretty Printing-  , simplifyVariableIndices-  , prettyProofMethod   , prettyProof   , prettyProofWith @@ -70,68 +63,39 @@   -- ** Parallel Strategy for exploring a proof   , parLTreeDFS -  -- * Convenience exports-  , module Theory.Proof.CaseDistinctions+  -- ** Small-step interface to the constraint solver+  , module Theory.Constraint.Solver+ ) where -import           Safe-import           Data.Maybe+import           Data.Binary+import           Data.DeriveTH+import           Data.Foldable                    (Foldable, foldMap) import           Data.List-import           Data.Ord (comparing)-import           Data.Function (on)-import qualified Data.Map               as M-import qualified Data.Set               as S+import qualified Data.Map                         as M+import           Data.Maybe import           Data.Monoid-import           Data.Foldable (Foldable, foldMap, asum) import           Data.Traversable-import qualified Data.Label             as L-import           Data.Label             hiding (get)-import           Data.DeriveTH-import           Data.Binary+import           Safe  import           Debug.Trace-                 + import           Control.Basics-import qualified Control.Monad.State    as S-import           Control.Monad.Bind-import qualified Control.Monad.Trans.PreciseFresh  as Precise-import           Control.Parallel.Strategies import           Control.DeepSeq+import qualified Control.Monad.State              as S+import           Control.Parallel.Strategies -import           Theory.Pretty-import           Theory.Proof.CaseDistinctions+import           Theory.Constraint.Solver+import           Theory.Model+import           Theory.Text.Pretty   --------------------------------------------------------------------------------- Utilities----------------------------------------------------------------------------------- | @uniqueListBy eq changes xs@ zips the @changes@ with all sequences equal--- elements in the list.------ > uniqueListBy compare id (const [ (++ show i) | i <- [1..] ]) ["a","b","a"] =--- > ["a1","b","a2"]----uniqueListBy :: (a -> a -> Ordering) -> (a -> a) -> (Int -> [a -> a]) -> [a] -> [a]-uniqueListBy ord single distinguish xs0 =-      map fst-    $ sortBy (comparing snd)-    $ concat $ map uniquify $ groupBy (\x y -> ord (fst x) (fst y) == EQ)-    $ sortBy (ord `on` fst)-    $ zip xs0 [(0::Int)..]-  where-    uniquify []      = error "impossible"-    uniquify [(x,i)] = [(single x, i)]-    uniquify xs      = zipWith (\f (x,i) -> (f x, i)) dist xs-      where-        dist = distinguish $ length xs-------------------------------------------------------------------------------- -- Utility: Trees with uniquely labelled edges. ------------------------------------------------------------------------------  -- | Trees with uniquely labelled edges.-data LTree l a = LNode +data LTree l a = LNode      { root     :: a      , children :: M.Map l (LTree l a)      }@@ -162,8 +126,8 @@ ------------------------------------------------------------------------------  -- | /O(n+m)/. A generalized union operator for maps with differing types.-mergeMapsWith :: Ord k -              => (a -> c) -> (b -> c) -> (a -> b -> c) +mergeMapsWith :: Ord k+              => (a -> c) -> (b -> c) -> (a -> b -> c)               -> M.Map k a -> M.Map k b -> M.Map k c mergeMapsWith leftOnly rightOnly combine l r =     M.map extract $ M.unionWith combine' l' r'@@ -180,75 +144,9 @@   --------------------------------------------------------------------------------- Contradictions----------------------------------------------------------------------------------- | Reasons why a sequent can be contradictory.-data Contradiction = -    Cyclic                         -- ^ The paths are cyclic.-  | NonNormalTerms                 -- ^ Has terms that are not in normal form.-  -- | NonLastNode                    -- ^ Has a non-silent node after the last node.-  | ForbiddenExp                   -- ^ Forbidden Exp-down rule instance-  | NonUniqueFactInstance (NodeId, NodeId, NodeId) -    -- ^ Contradicts that certain facts have unique instances.-  | IncompatibleEqs                -- ^ Incompatible equalities.-  | FormulasFalse                  -- ^ False in formulas-  | SuperfluousLearn LNTerm NodeId -- ^ A term is derived both before and after a learn-  deriving( Eq, Ord, Show )--instance HasFrees Contradiction where-  foldFrees f (SuperfluousLearn t v) = foldFrees f t `mappend` foldFrees f v-  foldFrees _ _                      = mempty--  mapFrees f (SuperfluousLearn t v) = -      SuperfluousLearn <$> mapFrees f t <*> mapFrees f v-  mapFrees _ c                      = pure c---- | A list of all trivial contradictions in the sequent.-contradictions :: SignatureWithMaude -> Sequent -> [Contradiction]-contradictions sig se = asum-    [ guard (proveCyclic se)                *> pure Cyclic-    , guard (hasNonNormalTerms sig se)      *> pure NonNormalTerms-    , guard (hasForbiddenExp se)            *> pure ForbiddenExp-    , guard (eqsIsFalse $ L.get sEqStore se)  *> pure IncompatibleEqs-    , guard (formulasFalse se)              *> pure FormulasFalse-    -- , guard (hasNonLastNode se)             *> pure NonLastNode-    -- , maybe [] (pure . uncurry SuperfluousLearn) $ findSuperfluousLearn se-    ]-    ++-    (NonUniqueFactInstance <$> nonUniqueFactInstances sig se)------------------------------------------------------------------------------------ Proof Methods----------------------------------------------------------------------------------- | Sound transformations of sequents.-data ProofMethod = -    Sorry String                         -- ^ Proof was not completed -  | Attack                               -- ^ An attack was fond-  | Simplify                             -- ^ A simplification step.-  | SolveGoal Goal                       -- ^ A goal was solved.-  | Contradiction (Maybe Contradiction)  -  | Induction-    -- ^ A contradiction could be derived, possibly with a reason.-  deriving( Eq, Ord, Show )--instance HasFrees ProofMethod where-    foldFrees f (SolveGoal g)     = foldFrees f g-    foldFrees f (Contradiction c) = foldFrees f c-    foldFrees _ _                 = mempty--    mapFrees f (SolveGoal g)     = SolveGoal <$> mapFrees f g-    mapFrees f (Contradiction c) = Contradiction <$> mapFrees f c-    mapFrees _ method            = pure method---------------------------------------------------------------------------------- -- Proof Steps -------------------------------------------------------------------------------    + -- | A proof steps is a proof method together with additional context-dependent -- information. data ProofStep a = ProofStep@@ -274,9 +172,6 @@ -- Proof Trees ------------------------------------------------------------------------------ --- | Every case in a proof is uniquely named.-type CaseName = String- -- | A path to a subproof. type ProofPath = [CaseName] @@ -307,7 +202,7 @@ modifyAtPath :: (Proof a -> Maybe (Proof a)) -> ProofPath              -> Proof a -> Maybe (Proof a) modifyAtPath f =-    go +    go   where     go []     prf = f prf     go (l:ls) prf = do@@ -345,8 +240,8 @@  -- | Fold a proof. foldProof :: Monoid m => (ProofStep a -> m) -> Proof a -> m-foldProof f = -    go +foldProof f =+    go   where     go (LNode step cs) = f step `mappend` foldMap go (M.elems cs) @@ -365,7 +260,7 @@ ----------------  -- | The status of a 'Proof'.-data ProofStatus = +data ProofStatus =          CompleteProof   -- ^ The proof is complete: no sorry, no attack        | IncompleteProof -- ^ There is a sorry, but no attack.        | TraceFound     -- ^ There is an attack@@ -381,177 +276,21 @@  -- | The status of a 'ProofStep'. proofStepStatus :: ProofStep a -> ProofStatus-proofStepStatus (ProofStep Attack _)    = TraceFound+proofStepStatus (ProofStep Solved _)    = TraceFound proofStepStatus (ProofStep (Sorry _) _) = IncompleteProof proofStepStatus (ProofStep _ _)         = CompleteProof --- | @cutOnAttackDFS prf@ remove all other cases if attack is found.--- FIXME: Probably holds onto the whole proof tree. Use iterative deepening.-cutOnAttackDFS :: Proof (Maybe Sequent) -> Proof (Maybe Sequent)-cutOnAttackDFS prf =-    case getFirst $ findAttacks $ insertPaths prf of-      Nothing   -> prf-      Just path -> extractAttack path prf-  where-    findAttacks (LNode (ProofStep Attack (_,path)) _) = First (Just path)-    findAttacks (LNode _ cs) = foldMap findAttacks $ M.elems cs-        {- The following "optimization" didn't work out in practice.-        foldMap findAttacks preferred `mappend` foldMap findAttacks delayed-      where-        (preferred, delayed) = parPartition prefer $ M.elems cs-        prefer = maybe False (S.null . L.get sChains) . fst . psInfo . root-        -} -    extractAttack []         p               = p-    extractAttack (label:ps) (LNode pstep m) = case M.lookup label m of-        Just subprf ->-          LNode pstep (M.fromList [(label, extractAttack ps subprf)])-        Nothing     ->-          error "Theory.Proof.cutOnAttackDFS: impossible, extractAttack failed, invalid path"---- | Search for attacks in a BFS manner.-cutOnAttackBFS :: Proof a -> Proof a-cutOnAttackBFS =-    go (1::Int)-  where-    go l prf = -      -- FIXME: See if that poor man's logging could be done better.-      trace ("searching for attacks at depth: " ++ show l) $-        case S.runState (checkLevel l prf) CompleteProof of-          (_, CompleteProof)   -> prf-          (_, IncompleteProof) -> go (l+1) prf-          (prf', TraceFound)  -> -              trace ("attack found at depth: " ++ show l) prf'--    checkLevel 0 (LNode  step@(ProofStep Attack _) _) = -        S.put TraceFound >> return (LNode step M.empty)-    checkLevel 0 prf@(LNode (ProofStep _ x) cs) -      | M.null cs = return prf-      | otherwise = do-          st <- S.get-          msg <- case st of-              TraceFound -> return $ "ignored (attack exists)"-              _           -> S.put IncompleteProof >> return "bound reached"-          return $ LNode (ProofStep (Sorry msg) x) M.empty-    checkLevel l (LNode step cs) =-         LNode step <$> traverse (checkLevel (l-1)) cs-       ----- Proof method execution------------------------------- @execMethod rules method se@ checks first if the @method@ is applicable to--- the sequent @se@. Then, it applies the @method@ to the sequent under the--- assumption that the @rules@ describe all rewriting rules in scope.-execProofMethod :: ProofContext -                -> ProofMethod -> Sequent -> Maybe (M.Map CaseName Sequent)-execProofMethod ctxt method se = -    case method of-      Sorry _              -> return M.empty-      Attack          -        | null (openGoals se) -> return M.empty-        | otherwise           -> Nothing-      SolveGoal goal       -> execSolveGoal goal-      Simplify             -> singleCase (/=) simplifySequent-      Induction            -> execInduction-      Contradiction _  -        | null (contradictions (L.get pcSignature ctxt) se) -> Nothing-        | otherwise                                       -> Just M.empty-  where-    -- Maude handle / signature to use-    hnd = L.get sigmMaudeHandle $ L.get pcSignature ctxt--    -- expect only one or no subcase in the given case distinction-    singleCase check m = -        case map fst $ execSeProof m ctxt se (avoid se) of-          []                   -> return $ M.empty-          [se'] | check se se' -> return $ M.singleton "" se'-                | otherwise    -> mzero-          ses                  -> -               return $ M.fromList (zip (map show [(1::Int)..]) ses)---             error $ "execMethod: unexpected number of sequents: " ++ show (length ses) ++---                     render (nest 2 $ vcat $ map ((text "" $-$) . prettySequent) ses)--    -- solve the given goal-    -- PRE: Goal must be valid in this sequent.-    execSolveGoal goal = do-        return $ makeCaseNames $ map fst $ getDisj $ -            runSeProof solver ctxt se (avoid se)-      where-        ths    = L.get pcCaseDists ctxt-        solver = do name <- maybe (solveGoal goal) -                                  (fmap $ concat . intersperse "_")-                                  (solveWithCaseDistinction hnd ths goal)-                    simplifySequent-                    return name--        makeCaseNames = -            M.fromListWith (error "case names not unique")-          . uniqueListBy (comparing fst) id distinguish-          where-            distinguish n = -                [ (\(x,y) -> (x ++ "_case_" ++ pad (show i), y)) -                | i <- [(1::Int)..] ]-              where-                l      = length (show n)-                pad cs = replicate (l - length cs) '0' ++ cs--    -- Apply induction: possible if the sequent contains only-    -- a single formula.-    execInduction-      | se == se0 =-          case S.toList $ L.get sFormulas se of-            [gf] -> case applyInduction gf of-              Right gf' -> Just $ M.singleton "induction" $ -                              set sFormulas (S.singleton gf') se-              _         -> Nothing-            _    -> Nothing--      | otherwise = Nothing-      where-        se0 = set sFormulas (L.get sFormulas se) $ -              set sLemmas (L.get sLemmas se)  $-              emptySequent (L.get sCaseDistKind se) ---- | A list of possibly applicable proof methods.-possibleProofMethods :: ProofContext -> Sequent -> [ProofMethod]-possibleProofMethods ctxt se =-         ((Contradiction . Just) <$> contradictions (L.get pcSignature ctxt) se)-     <|> (case L.get pcUseInduction ctxt of-            AvoidInduction -> [Simplify, Induction]-            UseInduction   -> [Induction, Simplify]-         )-     <|> (SolveGoal <$> openGoals se)---- | @proveSequentDFS rules se@ tries to construct a proof that @se@ is valid--- using a depth-first-search strategy to resolve the non-determinism wrt. what--- goal to solve next.  This proof can be of infinite depth, if the proof--- strategy loops. Children at the same level are evaluated in parallel.-proveSequentDFS :: ProofContext -> Sequent -> Proof Sequent-proveSequentDFS ctxt se0 = -    prove se0 -- `using` parLTreeDFS-  where-    prove se =-        LNode (ProofStep method se) (M.map prove cases)-      where-        (method, cases) = -            headDef (Attack, M.empty) $ do-                m <- possibleProofMethods ctxt se -                (m,) <$> maybe mzero return (execProofMethod ctxt m se)-- {- TODO: Test and probably improve- --- | @proveSequent rules se@ tries to construct a proof that @se@ is valid.++-- | @proveSystem rules se@ tries to construct a proof that @se@ is valid. -- This proof may contain 'Sorry' steps, if the prover is stuck. It can also be -- of infinite depth, if the proof strategy loops.-proveSequentIterDeep :: ProofContext -> Sequent -> Proof Sequent-proveSequentIterDeep rules se0 =+proveSystemIterDeep :: ProofContext -> System -> Proof System+proveSystemIterDeep rules se0 =     fromJust $ asum $ map (prove se0 . round) $ iterate (*1.5) (3::Double)   where-    prove :: Sequent -> Int -> Maybe (Proof Sequent)+    prove :: System -> Int -> Maybe (Proof System)     prove se bound       | bound < 0 = Nothing       | otherwise =@@ -559,9 +298,9 @@             [] -> pure $ sorry "prover stuck => possible attack found" se             xs -> asum $ map mkProof xs       where-        next = do m <- possibleProofMethods se +        next = do m <- possibleProofMethods se                   (m,) <$> maybe mzero return (execProofMethod rules m se)-        mkProof (method, cases) = +        mkProof (method, cases) =             LNode (ProofStep method se) <$> traverse (`prove` (bound - 1)) cases -} @@ -570,32 +309,25 @@ -- proof step without an annotated sequent. An unhandled case is denoted using -- the 'Sorry' proof method. checkProof :: ProofContext-           -> (Sequent -> Proof (Maybe Sequent)) -- prover for new cases-           -> Sequent +           -> (Int -> System -> Proof (Maybe System)) -- prover for new cases in depth+           -> Int         -- ^ Original depth+           -> System            -> Proof a-           -> Proof (Maybe a, Maybe Sequent)-checkProof ctxt prover se (LNode (ProofStep method info) cs) =-    fromMaybe (node method (M.map noSequentPrf cs)) $ headMay $ do-        method' <- method : possibleProofMethods ctxt se-        -- FIXME: eqModuloFreshness is too strict currently as it doesn't-        -- rename variables to a canonical representative. Moreover, it screws-        -- up if there are AC symbols involved.-        guard (method `eqModuloFreshnessNoAC` method')-        cases <- maybe mzero return $ execProofMethod ctxt method' se-        return $ node method' $ checkChildren cases-        -  where-    node m = LNode (ProofStep m (Just info, Just se)) +           -> Proof (Maybe a, Maybe System)+checkProof ctxt prover d se (LNode (ProofStep method info) cs) =+    fromMaybe (node method (M.map noSystemPrf cs)) $ headMay $ do+        cases <- maybe mzero return $ execProofMethod ctxt method se+        return $ node method $ checkChildren cases -    -- cases = msum (execProofMethod rules method se) $+  where+    node m = LNode (ProofStep m (Just info, Just se)) -    noSequentPrf = mapProofInfo (\i -> (Just i, Nothing))+    noSystemPrf = mapProofInfo (\i -> (Just i, Nothing)) -    checkChildren cases = -        mergeMapsWith unhandledCase noSequentPrf (checkProof ctxt prover) cases cs+    checkChildren cases =+        mergeMapsWith unhandledCase noSystemPrf (checkProof ctxt prover (d + 1)) cases cs       where-        unhandledCase = mapProofInfo ((,) Nothing) . prover-        +        unhandledCase = mapProofInfo ((,) Nothing) . prover d   ------------------------------------------------------------------------------@@ -604,38 +336,39 @@  -- | Incremental proofs are used to represent intermediate results of proof -- checking/construction.-type IncrementalProof = Proof (Maybe Sequent)+type IncrementalProof = Proof (Maybe System)  -- | Provers whose sequencing is handled via the 'Monoid' instance. -- -- > p1 `mappend` p2 -- -- Is a prover that first runs p1 and then p2 on the resulting proof.-newtype Prover =  Prover -          { runProver +newtype Prover =  Prover+          { runProver               :: ProofContext              -- proof rules to use-              -> Sequent                   -- original sequent to start with+              -> Int                       -- proof depth+              -> System                    -- original sequent to start with               -> IncrementalProof          -- original proof               -> Maybe IncrementalProof    -- resulting proof           }  instance Monoid Prover where-    mempty          = Prover $ \_     _  -> return-    p1 `mappend` p2 = Prover $ \rules se ->-        runProver p1 rules se >=> runProver p2 rules se+    mempty          = Prover $ \_  _ _ -> Just+    p1 `mappend` p2 = Prover $ \ctxt d se ->+        runProver p1 ctxt d se >=> runProver p2 ctxt d se  -- | Map the proof generated by the prover. mapProverProof :: (IncrementalProof -> IncrementalProof) -> Prover -> Prover-mapProverProof f p = Prover $ \ rules se prf -> f <$> runProver p rules se prf+mapProverProof f p = Prover $ \ ctxt d se prf -> f <$> runProver p ctxt d se prf  -- | Prover that always fails.-failProver :: Prover -failProver = Prover (\ _ _ _ -> Nothing)+failProver :: Prover+failProver = Prover (\ _ _ _ _ -> Nothing)  -- | Resorts to the second prover, if the first one is not successful. orelse :: Prover -> Prover -> Prover-orelse p1 p2 = Prover $ \rules se prf -> -    runProver p1 rules se prf `mplus` runProver p2 rules se prf+orelse p1 p2 = Prover $ \ctxt d se prf ->+    runProver p1 ctxt d se prf `mplus` runProver p2 ctxt d se prf  -- | Try to apply a prover. If it fails, just return the original proof. tryProver :: Prover -> Prover@@ -643,54 +376,43 @@  -- | Try to execute one proof step using the given proof method. oneStepProver :: ProofMethod -> Prover-oneStepProver method = Prover $ \rules se _ -> do-    cases <- execProofMethod rules method se+oneStepProver method = Prover $ \ctxt _ se _ -> do+    cases <- execProofMethod ctxt method se     return $ LNode (ProofStep method (Just se)) (M.map (unproven . Just) cases)  -- | Replace the current proof with a sorry step and the given reason. sorryProver :: String -> Prover-sorryProver reason = Prover $ \_ se _ -> return $ sorry reason (Just se)---- | Bound the depth of proofs generated by the given prover.-boundProver :: Int -> Prover -> Prover-boundProver b p = Prover $ \rules se prf ->-    boundProofDepth b <$> runProver p rules se prf---- | The standard automatic prover that ignores the existing proof and tries to--- find one by itself.-autoProver :: Prover-autoProver = Prover $ \rules se _ -> -    -- evaluate cases in parallel-    return $ fmap (fmap Just) $ proveSequentDFS rules se+sorryProver reason = Prover $ \_ _ se _ -> return $ sorry reason (Just se)  -- | Apply a prover only to a sub-proof, fails if the subproof doesn't exist. focus :: ProofPath -> Prover -> Prover focus []   prover = prover-focus path prover = -    Prover $ \rules _ prf -> modifyAtPath (prover' rules) path prf+focus path prover =+    Prover $ \ctxt d _ prf ->+        modifyAtPath (prover' ctxt (d + length path)) path prf   where-    prover' rules prf = do+    prover' ctxt d prf = do         se <- psInfo (root prf)-        runProver prover rules se prf+        runProver prover ctxt d se prf  -- | Check the proof and handle new cases using the given prover. checkAndExtendProver :: Prover -> Prover-checkAndExtendProver prover0 = Prover $ \rules se prf ->-    return $ mapProofInfo snd $ checkProof rules (prover rules) se prf+checkAndExtendProver prover0 = Prover $ \ctxt d se prf ->+    return $ mapProofInfo snd $ checkProof ctxt (prover ctxt) d se prf   where     unhandledCase   = sorry "unhandled case" Nothing-    prover rules se = -        fromMaybe unhandledCase $ runProver prover0 rules se unhandledCase+    prover ctxt d se =+        fromMaybe unhandledCase $ runProver prover0 ctxt d se unhandledCase --- | Replace all annotated sorry steps with +-- | Replace all annotated sorry steps with replaceSorryProver :: Prover -> Prover replaceSorryProver prover0 = Prover prover   where-    prover rules _ = return . replace+    prover ctxt d _ = return . replace       where-        replace prf@(LNode (ProofStep (Sorry _) (Just se)) _) = -            fromMaybe prf $ runProver prover0 rules se prf-        replace (LNode ps cases) = +        replace prf@(LNode (ProofStep (Sorry _) (Just se)) _) =+            fromMaybe prf $ runProver prover0 ctxt d se prf+        replace (LNode ps cases) =             LNode ps $ M.map replace cases  @@ -698,21 +420,139 @@ firstProver :: [Prover] -> Prover firstProver = foldr orelse failProver --- | Prover that does one contradiction step or one graph clause resolution--- step.-contradictionAndClauseProver :: Prover-contradictionAndClauseProver = Prover $ \ctxt se prf ->-    runProver -        (firstProver $ map oneStepProver $ -            (Contradiction . Just <$> -                contradictions (L.get pcSignature ctxt) se))-        ctxt se prf+-- | Prover that does one contradiction step.+contradictionProver :: Prover+contradictionProver = Prover $ \ctxt d sys prf ->+    runProver+        (firstProver $ map oneStepProver $+            (Contradiction . Just <$> contradictions ctxt sys))+        ctxt d sys prf +------------------------------------------------------------------------------+-- Automatic Prover's+------------------------------------------------------------------------------ +data SolutionExtractor = CutDFS | CutBFS | CutNothing++data AutoProver = AutoProver+    { apHeuristic :: Heuristic+    , apBound     :: Maybe Int+    , apCut       :: SolutionExtractor+    }++runAutoProver :: AutoProver -> Prover+runAutoProver (AutoProver heuristic bound cut) =+    mapProverProof cutSolved $ maybe id boundProver bound autoProver+  where+    cutSolved = case cut of+      CutDFS     -> cutOnSolvedDFS+      CutBFS     -> cutOnSolvedBFS+      CutNothing -> id++    -- | The standard automatic prover that ignores the existing proof and+    -- tries to find one by itself.+    autoProver :: Prover+    autoProver = Prover $ \ctxt depth se _ ->+        return $ fmap (fmap Just) $ proveSystemDFS heuristic ctxt depth se++    -- | Bound the depth of proofs generated by the given prover.+    boundProver :: Int -> Prover -> Prover+    boundProver b p = Prover $ \ctxt d se prf ->+        boundProofDepth b <$> runProver p ctxt d se prf+++-- | The result of one pass of iterative deepening.+data IterDeepRes = NoSolution | MaybeNoSolution | Solution ProofPath++instance Monoid IterDeepRes where+    mempty = NoSolution++    x@(Solution _)   `mappend` _                = x+    _                `mappend` y@(Solution _)   = y+    MaybeNoSolution  `mappend` _                = MaybeNoSolution+    _                `mappend` MaybeNoSolution  = MaybeNoSolution+    NoSolution       `mappend` NoSolution       = NoSolution++-- | @cutOnSolvedDFS prf@ removes all other cases if an attack is found. The+-- attack search is performed using a parallel DFS traversal with iterative+-- deepening.+--+-- FIXME: Note that this function may use a lot of space, as it holds onto the+-- whole proof tree.+cutOnSolvedDFS :: Proof (Maybe System) -> Proof (Maybe System)+cutOnSolvedDFS prf0 =+    go (4 :: Integer) $ insertPaths prf0+  where+    go dMax prf = case findSolved 0 prf of+        NoSolution      -> prf0+        MaybeNoSolution -> go (2 * dMax) prf+        Solution path   -> extractSolved path prf0+      where+        findSolved d node+          | d >= dMax = MaybeNoSolution+          | otherwise = case node of+              LNode (ProofStep Solved (_,path)) _ -> Solution path+              LNode _ cs                          ->+                mconcat $ parMap rseq (findSolved (succ d)) $ M.elems cs++    extractSolved []         p               = p+    extractSolved (label:ps) (LNode pstep m) = case M.lookup label m of+        Just subprf ->+          LNode pstep (M.fromList [(label, extractSolved ps subprf)])+        Nothing     ->+          error "Theory.Constraint.cutOnSolvedDFS: impossible, extractSolved failed, invalid path"+++-- | Search for attacks in a BFS manner.+cutOnSolvedBFS :: Proof a -> Proof a+cutOnSolvedBFS =+    go (1::Int)+  where+    go l prf =+      -- FIXME: See if that poor man's logging could be done better.+      trace ("searching for attacks at depth: " ++ show l) $+        case S.runState (checkLevel l prf) CompleteProof of+          (_, CompleteProof)   -> prf+          (_, IncompleteProof) -> go (l+1) prf+          (prf', TraceFound)  ->+              trace ("attack found at depth: " ++ show l) prf'++    checkLevel 0 (LNode  step@(ProofStep Solved _) _) =+        S.put TraceFound >> return (LNode step M.empty)+    checkLevel 0 prf@(LNode (ProofStep _ x) cs)+      | M.null cs = return prf+      | otherwise = do+          st <- S.get+          msg <- case st of+              TraceFound -> return $ "ignored (attack exists)"+              _           -> S.put IncompleteProof >> return "bound reached"+          return $ LNode (ProofStep (Sorry msg) x) M.empty+    checkLevel l (LNode step cs) =+         LNode step <$> traverse (checkLevel (l-1)) cs+++-- | @proveSystemDFS rules se@ tries to construct a proof that @se@ is valid+-- using a depth-first-search strategy to resolve the non-determinism wrt. what+-- goal to solve next.  This proof can be of infinite depth, if the proof+-- strategy loops. Children at the same level are evaluated in parallel.+proveSystemDFS :: Heuristic -> ProofContext -> Int -> System -> Proof System+proveSystemDFS heuristic ctxt d0 sys0 =+    prove d0 sys0 -- `using` parLTreeDFS+  where+    prove !depth sys =+        case rankProofMethods (useHeuristic heuristic depth) ctxt sys of+          []                         -> node Solved M.empty+          (method, (cases, _expl)):_ -> node method cases+      where+        node method cases =+          LNode (ProofStep method sys) (M.map (prove (succ depth)) cases)+ ------------------------------------------------------------------------------ -- Pretty printing ------------------------------------------------------------------------------ +{- NOT used anymore+ -- | Consistently simplify variable indices in the proof; i.e., rename all -- free variables in a top-down fashion using the 'Precise.FreshT' -- transformer.@@ -724,33 +564,9 @@         case Precise.runFresh (runBindT (someInst step) bindSt) freshSt of             ((step', bindSt'), freshSt') ->                 LNode step' (M.map (go bindSt' freshSt') cs)+-}  -prettyContradiction :: Document d => Contradiction -> d-prettyContradiction contra = case contra of-    Cyclic                    -> text "cyclic"-    IncompatibleEqs           -> text "incompatible equalities"-    NonNormalTerms            -> text "non-normal terms"-    ForbiddenExp              -> text "non-normal exponentiation instance"-    NonUniqueFactInstance cex -> text $ "non-unique facts" ++ show cex-    FormulasFalse             -> text "from formulas"-    SuperfluousLearn m v      ->-        doubleQuotes (prettyLNTerm m) <->-        text ("derived before and after") <-> -        doubleQuotes (prettyNodeId v)--prettyProofMethod :: HighlightDocument d => ProofMethod -> d-prettyProofMethod method = case method of-    Attack               -> keyword_ "SOLVED" <-> lineComment_ "trace found"-    Induction            -> keyword_ "induction"-    Sorry reason         -> fsep [keyword_ "sorry", lineComment_ reason]-    SolveGoal goal       -> hsep [keyword_ "solve(", prettyGoal goal, keyword_ ")"]-    Simplify             -> keyword_ "simplify"-    Contradiction reason ->-        fsep [ keyword_ "contradiction"-             , maybe emptyDoc (lineComment . prettyContradiction) reason-             ]- prettyProof :: HighlightDocument d => Proof a -> d prettyProof = prettyProofWith (prettyProofMethod . psMethod) (const id) @@ -764,13 +580,13 @@   where     ppPrf (LNode ps cs) = ppCases ps (M.toList cs) -    ppCases ps@(ProofStep Attack _) [] = prettyStep ps-    ppCases ps []                      = prettyCase ps (kwBy <> text " ") +    ppCases ps@(ProofStep Solved _) [] = prettyStep ps+    ppCases ps []                      = prettyCase ps (kwBy <> text " ")                                            <> prettyStep ps     ppCases ps [("", prf)]             = prettyStep ps $-$ ppPrf prf     ppCases ps cases                   =         prettyStep ps $-$-        (vcat $ intersperse (prettyCase ps kwNext) $ map ppCase cases) $-$ +        (vcat $ intersperse (prettyCase ps kwNext) $ map ppCase cases) $-$         prettyCase ps kwQED      ppCase (name, prf) = nest 2 $@@ -778,7 +594,7 @@       ppPrf prf  -- | Convert a proof status to a redable string.-showProofStatus :: SequentTraceQuantifier -> ProofStatus -> String+showProofStatus :: SystemTraceQuantifier -> ProofStatus -> String showProofStatus ExistsNoTrace   TraceFound      = "falsified - found trace" showProofStatus ExistsNoTrace   CompleteProof   = "verified" showProofStatus ExistsSomeTrace CompleteProof   = "falsified - no trace found"@@ -789,15 +605,15 @@ -- Derived instances -------------------- -$( derive makeBinary ''Contradiction)-$( derive makeBinary ''ProofMethod) $( derive makeBinary ''ProofStep) $( derive makeBinary ''ProofStatus)+$( derive makeBinary ''SolutionExtractor)+$( derive makeBinary ''AutoProver) -$( derive makeNFData ''Contradiction)-$( derive makeNFData ''ProofMethod) $( derive makeNFData ''ProofStep) $( derive makeNFData ''ProofStatus)+$( derive makeNFData ''SolutionExtractor)+$( derive makeNFData ''AutoProver)  instance (Ord l, NFData l, NFData a) => NFData (LTree l a) where   rnf (LNode r m) = rnf r `seq` rnf  m
− src/Theory/Proof/CaseDistinctions.hs 
@@ -1,350 +0,0 @@-{-# LANGUAGE DeriveDataTypeable, TupleSections, TypeOperators,-             TemplateHaskell, TypeSynonymInstances, FlexibleInstances,-             FlexibleContexts, GeneralizedNewtypeDeriving, ViewPatterns-  #-}--- |--- Copyright   : (c) 2011,2012 Simon Meier--- License     : GPL v3 (see LICENSE)--- --- Maintainer  : Simon Meier <iridcode@gmail.com>--- Portability : GHC only------ Big-step proofs using case distinctions on the possible sources of a fact.-module Theory.Proof.CaseDistinctions (-  -- * Big-step case distinctions-  -- | Types declared in "Theory.Proof.Types"--  -- ** Queries-    unsolvedChainConstraints--  -- ** Construction-  , precomputeCaseDistinctions-  , refineWithTypingAsms--  -- ** Application-  , solveWithCaseDistinction --  -- ** Pretty-printing-  , prettyBigStepGoal--  -- * Convenience export of used modules-  , module Theory.Proof.Sequent-  ) where--import           Safe-import           Prelude hiding ( (.), id )--import qualified Data.Set         as S-import           Data.Foldable (asum)--import           Control.Basics-import           Control.Category-import           Control.Monad.Disj--- import           Control.Monad.Bind-import           Control.Monad.Reader-import           Control.Monad.State (gets)-import           Control.Parallel.Strategies--import           Text.PrettyPrint.Highlight--import           Extension.Prelude-import           Extension.Data.Label--import           Theory.Rule-import           Theory.Proof.Sequent------------------------------------------------------------------------------------ Big Step Proofs----------------------------------------------------------------------------------- | The number of remaining chain constraints of each case.-unsolvedChainConstraints :: CaseDistinction -> [Int]-unsolvedChainConstraints =-    map (S.size . get sChains . snd . snd) . getDisj . get cdCases----- Construction-------------------- | The initial case distinction if the given goal is required and the--- given typing assumptions are justified.-initialCaseDistinction :: ProofContext -                       -> [LNGuarded] -- ^ Typing assumptions.-                       -> LNFact -> CaseDistinction-initialCaseDistinction ctxt typAsms goalFa =-    CaseDistinction goalFa cases-  where-    polish (((name, prem), se), _) = ([name], (prem, se))-    se0   = set sFormulas (S.fromList typAsms) (emptySequent UntypedCaseDist)-    cases = fmap polish $ runSeProof instantiate ctxt se0 (avoid (goalFa, se0))-    instantiate = do-        i <- freshLVar "i" LSortNode-        let p   = (i, PremIdx 0)-            err = error . ("requiresCasesThm: no or too many edges: " ++)-        name <- solveGoal (PremiseG p goalFa False)-        edges <- getM sEdges-        case filter ((p ==) . eTgt) (S.toList edges) of-          [e] -> do modM sEdges (S.delete e)-                    return (name, eSrc e)-          es  -> err $ show es---- | Refine a source case distinction by applying the additional proof step.-refineCaseDistinction -    :: ProofContext-    -> SeProof (a, [String])  -- proof step with result and path extension-    -> CaseDistinction -    -> ([a],CaseDistinction)-refineCaseDistinction ctxt proofStep th = -    ( map fst $ getDisj refinement-    , set cdCases (snd <$> refinement) th )-  where-    fs         = avoid th-    refinement = do-        (names, (p, se))   <- get cdCases th-        ((x, names'), se') <- fst <$> runSeProof proofStep ctxt se fs-        return (x, (combine names names', (p, se')))--    -- Combine names such that the coerce rule is blended out.-    combine []            ns' = ns'-    combine ("coerce":ns) ns' = combine ns ns'-    combine (n       :_)  _   = [n]---- | Solves all chain and splitting goals as well as all premise goals solvable--- with one of the given precomputed requires case distinction theorems, while--- repeatedly simplifying the proof state. ------ Returns the names of the steps applied.-solveAllSafeGoals :: [CaseDistinction] -> SeProof [String]-solveAllSafeGoals ths = -    solve []-  where-    safeGoal _            (ChainG _)              = True-    safeGoal _            (PremDnKG _)            = True-    safeGoal _            (ActionG _ _)           = True-    safeGoal splitAllowed (DisjG _)               = splitAllowed-    -- NOTE: Uncomment the line below to get more extensive case splitting-    -- for precomputed case distinctions.-    -- safeGoal splitAllowed (SplitG _ _) = splitAllowed-    safeGoal _            (PremiseG _ fa mayLoop) = not (mayLoop || isKFact fa)-    safeGoal _            _                       = False--    nonLoopingGoal (PremiseG _ _ mayLoop) = not mayLoop-    nonLoopingGoal _                      = True--    solve caseNames = do-        simplifySequent-        sig <- askM pcSignature-        contradictoryIf =<< gets (contradictorySequent sig)-        goals  <- gets openGoals-        chains <- getM sChains-        hnd    <- getMaudeHandle-        -- try to either solve a safe goal or use one of the precomputed case-        -- distinctions-        let noChainGoals = null [ () | ChainG _ <- goals ]-            -- we perform equation splits, if there is a chain goal starting-            -- from a message variable; i.e., a chain constraint that is no-            -- open goal.-            splitAllowed    = noChainGoals && not (S.null chains)-            safeGoals       = filter (safeGoal splitAllowed) goals-            nonLoopingGoals = filter nonLoopingGoal goals-            nextStep        = -                ((fmap return . solveGoal) <$> headMay safeGoals) <|>-                (asum $ map (solveWithCaseDistinction hnd ths) nonLoopingGoals)-        case nextStep of-          Nothing   -> return $ caseNames-          Just step -> solve . (caseNames ++) =<< step------------------------------------------------------------------------------------ Applying precomputed case distinctions----------------------------------------------------------------------------------- | A goal for a big step case distinction.-data BigStepGoal = -       PremiseBigStep NodePrem LNFact Bool-     | MessageBigStep (Either NodeId NodePrem) LNTerm-       -- ^ Left means solving a deduction action, Right a node premise.-     deriving( Eq, Ord, Show )---- | Convert a standard goal to a big-step goal.-toBigStepGoal :: Goal -> Maybe BigStepGoal-toBigStepGoal goal = case goal of-    PremiseG p fa mayLoop             -> return $ PremiseBigStep p fa mayLoop-    PremUpKG p m                      -> return $ MessageBigStep (Right p) m-    ActionG i (dedFactView -> Just m) -> return $ MessageBigStep (Left i)  m-    _                                 -> mzero--fromBigStepGoal :: BigStepGoal -> Goal-fromBigStepGoal goal = case goal of-    PremiseBigStep p fa mayLoop -> PremiseG p fa mayLoop-    MessageBigStep (Left i)  m  -> ActionG i (dedLogFact m)-    MessageBigStep (Right p) m  -> PremUpKG p m----- | AC-Matching for big-step goals. MessageBigSteps can be matched--- to the corresponding K-up facts.-matchBigStepGoal :: BigStepGoal -- ^ Term.-                 -> LNFact      -- ^ Pattern.-                 -> WithMaude [LNSubst]-matchBigStepGoal (PremiseBigStep _ faTerm _) faPat = matchLNFact faTerm faPat-matchBigStepGoal (MessageBigStep _ mTerm)    faPat =-    case kFactView faPat of-      Just (UpK, _, mPat) -> matchLNTerm [mTerm `MatchWith` mPat]-      _                   -> return []---- | Try to solve a premise goal or 'Ded' action using the first precomputed--- case distinction with a matching premise.-solveWithCaseDistinction :: MaudeHandle-                         -> [CaseDistinction] -                         -> Goal-                         -> Maybe (SeProof [String])-solveWithCaseDistinction hnd ths goal0 = do-    goal <- toBigStepGoal goal0-    asum [ applyCaseDistinction hnd th goal | th <- ths ]---- | Apply a precomputed case distinction theorem to a required fact.-applyCaseDistinction :: MaudeHandle-                     -> CaseDistinction    -- ^ Case distinction theorem.-                     -> BigStepGoal        -- ^ Required goal-                     -> Maybe (SeProof [String])-applyCaseDistinction hnd th goal =-    case (`runReader` hnd) $ matchBigStepGoal goal (get cdGoal th) of-      [] -> Nothing-      _  -> Just $ do (names, subst, seTh) <- instTheorem-                      solveSubstEqs SplitNow subst-                      conjoinSequent seTh-                      return names-  where-    instTheorem :: SeProof ([String], LNSubst, Sequent)-    instTheorem = do-        instTh <- rename th-        -- We only have to choose one matcher, as the theorem holds for all-        -- premises equal modulo AC.-        subst <- disjunctionOfList $ take 1 $ -                 matchBigStepGoal goal (get cdGoal instTh) `runReader` hnd-        (names, (concTh, seTh)) <- disjunctionOfList $ getDisj $ get cdCases instTh--        seTh' <- case goal of-            PremiseBigStep prem _ _ -> -                return $ modify sEdges (S.insert (Edge concTh prem)) seTh-            MessageBigStep (Right prem) _ -> -                return $ modify sMsgEdges (S.insert (MsgEdge concTh prem)) seTh-            MessageBigStep (Left i) m -> do-                -- remove solved atom-                modM sAtoms (S.delete (Action (varTerm i) (dedLogFact m)))-                return seTh--        -- solving the matcher equalities and -        -- conjoining the sequent will be done later-        return (names, subst, seTh')---- | Saturate the case distinctions with respect to each other such that no--- additional splitting is introduced; i.e., only rules with a single or no--- conclusion are used for the saturation.-saturateCaseDistinctions -    :: ProofContext -> [CaseDistinction] -> [CaseDistinction]-saturateCaseDistinctions ctxt = -    go-  where-    go ths =-        if any or (changes `using` parList rdeepseq)-          then go ths'-          else ths'-      where-        (changes, ths') = unzip $ map (refineCaseDistinction ctxt solver) ths-        noSplitThs = filter ((<= 1) . length . getDisj . get cdCases) ths-        solver     = do names <- solveAllSafeGoals noSplitThs-                        return (not $ null names, names)--{--    go changed done []-      | changed   = go False [] (reverse done)-      | otherwise = reverse done-    go changed done (th:ths) =-        go (changed || or changes ) (th':done) ths-      where-        solver         = do names <- solveAllSafeGoals nonLoopingFact noSplitThs-                            return (not $ null names, names)-        (changes, th') = refineCaseDistinction ctxt solver th-        noSplitThs     = -            filter ((<= 1) . length . getDisj . get cdCases) (done ++ ths)--}---- | Precompute a saturated set of case distinctions.-precomputeCaseDistinctions -    :: ProofContext -    -> [LNGuarded] -- ^ Typing assumptions.-    -> [CaseDistinction]-precomputeCaseDistinctions ctxt typAsms =-    map cleanupCaseNames $ saturateCaseDistinctions ctxt rawCaseDists-  where-    cleanupCaseNames = modify cdCases $ fmap $ first $-        filter (not . null)-      . map (filter (`elem` '_' : ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9']))--    rawCaseDists = -      initialCaseDistinction ctxt typAsms <$> (protoGoals ++ msgGoals)--    -- construct case distinction starting from facts from non-special rules-    protoGoals = someProtoGoal <$> absProtoFacts -    msgGoals   = someKUGoal <$> absMsgFacts--    getProtoFact (Fact KUFact _ ) = mzero-    getProtoFact (Fact KDFact _ ) = mzero-    getProtoFact fa               = return fa--    absFact (Fact tag ts) = (tag, length ts)--    nMsgVars n = [ varTerm (LVar "t" LSortMsg i) | i <- [1..fromIntegral n] ]--    someProtoGoal :: (FactTag, Int) -> LNFact-    someProtoGoal (tag, arity) = Fact tag (nMsgVars arity)--    someKUGoal :: LNTerm -> LNFact-    someKUGoal m = Fact KUFact [varTerm (LVar "f_" LSortMsg 0), m]--    -- FIXME: Also use facts from proof context.-    rules = get pcRules ctxt-    absProtoFacts = sortednub $ do-        ru <- joinAllRules rules-        fa <- absFact <$> (getProtoFact =<< (get rConcs ru ++ get rPrems ru))-        -- exclude facts handled specially by the prover-        guard (not $ fst fa `elem` [OutFact, InFact, FreshFact])-        return fa--    absMsgFacts :: [LNTerm]-    absMsgFacts = asum $ sortednub $ -      [ do return $ lit $ Var (LVar "t" LSortFresh 1)--      , [ fAppNonAC (s,k) $ nMsgVars k-        | (s,k) <- S.toList . allFunctionSymbols  . mhMaudeSig . get sigmMaudeHandle . get pcSignature $ ctxt-        , (s,k) `S.notMember` implicitFunSig, k > 0 ]-      ] ---- | Refine a set of case distinction by exploiting additional typing--- assumptions.-refineWithTypingAsms -    :: [LNGuarded]        -- ^ Typing assumptions to use.-    -> ProofContext       -- ^ Proof context to use.-    -> [CaseDistinction]  -- ^ Original, untyped case distinctions.-    -> [CaseDistinction]  -- ^ Refined, typed case distinctions.-refineWithTypingAsms typAsms ctxt cases0 =-    fmap (modifySequents removeFormulas) $-    saturateCaseDistinctions ctxt $ -    modifySequents updateSequent <$> cases0-  where-    modifySequents = modify cdCases . fmap . second . second-    updateSequent se = -        modify sFormulas (S.union (S.fromList typAsms)) $-        set sCaseDistKind TypedCaseDist                 $ se-    removeFormulas = set sFormulas S.empty . set sSolvedFormulas S.empty----------------------------------------------------------------------------------- Pretty-printing---------------------------------------------------------------------------------prettyBigStepGoal :: HighlightDocument d => BigStepGoal -> d-prettyBigStepGoal = prettyGoal . fromBigStepGoal--
− src/Theory/Proof/EquationStore.hs 
@@ -1,424 +0,0 @@-{-# LANGUAGE TypeOperators, TemplateHaskell, DeriveDataTypeable #-}-{-# LANGUAGE ScopedTypeVariables, TupleSections, ViewPatterns #-}--- |--- Copyright   : (c) 2010-2012 Benedikt Schmidt--- License     : GPL v3 (see LICENSE)--- --- Maintainer  : Benedikt Schmidt <beschmi@gmail.com>--- Portability : GHC only------ Support for reasoning with and about disjunctions of substitutions.-module Theory.Proof.EquationStore (--  -- * Transformation-    simp-  , addEqs-  , addRuleVariants-  , splitAtPos-  , eqSplits-  , splitCasenum-  , constrainedVarsPos--  , SplitStrategy(..)--  -- * simplify a disjunction-  , simpDisjunction--) where--import Term.Unification-import Logic.Connectives-import Theory.Proof.Types--import Control.Monad.Reader-import Control.Monad.Fresh-import Utils.Misc-import Extension.Prelude--import Debug.Trace.Ignore--import Data.List-import Data.Label hiding ( for )-import Data.Maybe-import Safe-import Data.Monoid-import qualified Data.Foldable as F-import qualified Data.Set as S-import Control.Basics-import Control.Monad.State hiding (get, modify)-import qualified Control.Monad.State as MS----- Equation Store--------------------------------------------------------------------------- | We use the empty set (disjunction) to denote false.-falseDisj :: S.Set LNSubstVFresh-falseDisj = S.empty---- | 'SplitStrategy' denotes if the equation store should be split into--- multiple equation stores.-data SplitStrategy = SplitNow | SplitLater---- Dealing with equations--------------------------------------------------------------------------- | Returns the list of all @SplitId@s valid for the given equation store--- sorted by the size of the disjunctions.-eqSplits :: EqStore -> [SplitId]-eqSplits eqs =-    map fst . sortOn snd $ zip [0..] (map S.size . getConj . get eqsConj $ eqs)----- | Returns the number of cases for a given 'SplitId'.-splitCasenum :: EqStore -> SplitId -> Int-splitCasenum eqs sid = case atMay (getConj . get eqsConj $ eqs) sid of-    Just disj -> S.size disj-    Nothing   -> error "splitCasenum: invalid split id"----- | Add a disjunction to the equation store at the beginning-addDisj :: EqStore -> (S.Set LNSubstVFresh) -> EqStore-addDisj eqStore disj = modify eqsConj ((Conj [disj]) `mappend`) eqStore----- | @splitEqStoreAt eqs i@ takes the disjunction at position @i@ in @eqs@---   and returns a list of resulting substitutions and the equality store---   with the remaining equations.-splitAtPos :: EqStore -> Int -> Maybe [EqStore]-splitAtPos eqStore i-    | i `notElem` eqSplits eqStore = Nothing-    | otherwise = Just $ map (\d -> set eqsConj (conjNew d) eqStore) disj-  where-    conj = getConj $ get eqsConj eqStore-    disj = S.toList (conj !! i)-    conjNew d = Conj $ take i conj ++ [ S.singleton d ] ++ drop (i+1) conj----- | Add a list of term equalities to the equation store.---   Returns the resulting equation store(s) depending---   on the split strategy.-addEqs :: MonadFresh m => SplitStrategy -> MaudeHandle-                       -> [Equal LNTerm] -> EqStore -> m [EqStore]-addEqs splitStrat hnd eqs0 eqStore =-    case unifyLNTermFactored eqs `runReader` hnd of-        (_, [])         -> return [ set eqsConj falseEqConstrConj eqStore ]-        (subst, [ substFresh ]) | substFresh == emptySubstVFresh ->-            return [ applyEqStore hnd subst eqStore ]-        (subst, substs) ->-            case splitStrat of-                SplitLater ->-                    return [ addDisj (applyEqStore hnd subst eqStore) (S.fromList substs) ]-                SplitNow ->-                    addEqsAC (modify eqsSubst (compose subst) eqStore)-                        <$> simpDisjunction hnd (const False) (Disj substs)-  where-    eqs = apply (get eqsSubst eqStore) $ trace (unlines ["addEqs: ", show eqs0]) $ eqs0-    addEqsAC eqSt (sfree, Nothing)   = [ applyEqStore hnd sfree eqSt ]-    addEqsAC eqSt (sfree, Just disj) =-      fromMaybe (error "addEqsSplit: impossible, splitAtPos failed")-                (splitAtPos (applyEqStore hnd sfree (addDisj eqSt (S.fromList disj))) 0)----- | Apply a substitution to an equation store and bring resulting equations into---   normal form again by using unification.-applyEqStore :: MaudeHandle -> LNSubst -> EqStore -> EqStore-applyEqStore hnd asubst eqStore-    | dom asubst `intersect` varsRange asubst /= [] || trace (show ("applyEqStore", asubst, eqStore)) False-    = error $ "applyEqStore: dom and vrange not disjoint for `"++show asubst++"'"-    | otherwise-    = modify eqsConj (fmap (S.fromList . concatMap applyBound  . S.toList)) $-          set eqsSubst newsubst eqStore-  where-    newsubst = asubst `compose` get eqsSubst eqStore-    applyBound s = map (restrictVFresh (varsRange newsubst ++ domVFresh s)) $ -        (`runReader` hnd) $ unifyLNTerm-          [ Equal (apply newsubst (varTerm lv)) t-          | let slist = substToListVFresh s,-            -- variables in the range are fresh, so we have to rename-            -- them away from all other variables in unification problem-            -- NOTE: these variables never enter the global context-            let ran = renameAvoiding (map snd slist)-                                     (domVFresh s ++ varsRange newsubst),-            (lv,t) <- zip (map fst slist) ran-          ]--{- NOTES for @applyEqStore tau@ to a fresh substitution sigma:-[ FIXME: extend explanation to multiple unifiers ]-Let dom(sigma) = x1,..,xk, vrange(sigma) = y1, .. yl, vrange(tau) = z1,..,zn-Fresh substitution denotes formula-  exists #y1, .., #yl. x1 = t1 /\ .. /\ xk = tk-for variables #yi that do not clash with xi and zi [renameAwayFrom]-and with vars(ti) `subsetOf` [#y1, .. #yl].-We apply tau with vrange(tau) = z1,..,zn to the formula to obtain-  exists ##y1, .., ##yl. tau(x1) = t1 /\ .. /\ tau(xk) = tk-unification then yields a lemma-  forall xi zi #yi.-    tau(x1) = t1 /\ .. /\ tau(xk) = tk-    <-> exists vars(s1,..sm). x1 = .. /\ z1 = .. /\ #y1 = ..-So we have-  exists #y1, .., #yl.-    exists vars(s1,..sm). x1 = .. /\ z1 = .. /\ #y1 = ..-<=>-  exists vars(s1,..sm). x1 = .. /\ z1 = ..-      /\  (exists #y1, .., #yl. #y1 = ..)-<=> [restric]-  exists vars(s1,..sm). x1 = .. /\ z1 = .. /\ True--}---- | Add the given rule variants.-addRuleVariants :: Disj LNSubstVFresh -> EqStore -> EqStore-addRuleVariants (Disj substs) eqStore-    | dom freeSubst `intersect` concatMap domVFresh substs /= []-    = error $ "addRuleVariants: Nonempty intersection between domain of variants and free substitution. "-              ++"This case has not been implemented, add rule variants earlier."-    | otherwise = addDisj eqStore (S.fromList substs)-  where-    freeSubst = get eqsSubst eqStore----- | Return the set of variables that is constrained by disjunction at give position.-constrainedVarsPos :: EqStore -> Int -> [LVar]-constrainedVarsPos eqStore k-    | k < length conj = frees (conj!!k)-    | otherwise       = []-  where-    conj = getConj . get eqsConj $ eqStore---- Simplifying disjunctions--------------------------------------------------------------------------- | Simplify given disjunction via EqStore simplification. Obtains fresh---   names for variables from the underlying 'MonadFresh'.-simpDisjunction :: MonadFresh m-                => MaudeHandle-                -> (LNSubstVFresh -> Bool)-                -> Disj LNSubstVFresh-                -> m (LNSubst, Maybe [LNSubstVFresh])-simpDisjunction hnd isContr disj0 = do-    eqStore' <- simp hnd isContr eqStore-    return (get eqsSubst eqStore', wrap $ get eqsConj eqStore')-  where-    eqStore = set eqsConj (Conj [ S.fromList . getDisj $ disj0 ]) $ emptyEqStore-    wrap (Conj [])     = Nothing-    wrap (Conj [disj]) = Just $ S.toList disj-    wrap conj          =-        error ("simplifyDisjunction: imposible, unexpected conjuction `"-               ++ show conj ++ "'")----- Simplification--------------------------------------------------------------------------- | @simp eqStore@ simplifies the equation store.-simp :: MonadFresh m => MaudeHandle -> (LNSubstVFresh -> Bool) -> EqStore -> m EqStore-simp hnd isContr eqStore =-    (`execStateT` (trace (show ("eqStore", eqStore)) eqStore)) $ whileTrue (simp1 hnd isContr)----- | @simp1@ tries to execute one simplification step---   for the equation store. It returns @True@ if---   the equation store was modified.-simp1 :: MonadFresh m => MaudeHandle -> (LNSubstVFresh -> Bool) -> StateT EqStore m Bool-simp1 hnd isContr = do-    s <- MS.get-    if eqsIsFalse s-        then return False-        else do-          b1 <- simpMinimize isContr-          b2 <- simpRemoveRenamings-          b3 <- simpEmptyDisj-          b4 <- foreachDisj hnd simpSingleton-          b5 <- foreachDisj hnd simpAbstractSortedVar-          b6 <- foreachDisj hnd simpIdentify-          b7 <- foreachDisj hnd simpAbstractFun-          b8 <- foreachDisj hnd simpAbstractName-          (trace (show ("simp:", [b1, b2, b3, b4, b5, b6, b7, b8]))) $ return $ (or [b1, b2, b3, b4, b5, b6, b7, b8])----- | Remove variable renamings in fresh substitutions.-simpRemoveRenamings :: MonadFresh m => StateT EqStore m Bool-simpRemoveRenamings = do-    conj <- gets (get eqsConj)-    if F.any (S.foldl' (\b subst -> b || domVFresh subst /= domVFresh (removeRenamings subst)) False) conj-      then MS.modify (set eqsConj $ fmap (S.map removeRenamings) conj) >> return True-      else return False----- | If empty disjunction is found, the whole conjunct---   can be simplified to False.-simpEmptyDisj :: MonadFresh m => StateT EqStore m Bool-simpEmptyDisj = do-    conj <- gets (get eqsConj)-    if (F.any (==falseDisj) conj && conj /= falseEqConstrConj)-      then MS.modify (set eqsConj falseEqConstrConj) >> return True-      else return False----- | If there is a singleton disjunction, it can be---   composed with the free substitution.-simpSingleton :: MonadFresh m-              => [LNSubstVFresh]-              -> m (Maybe (Maybe LNSubst, [S.Set LNSubstVFresh]))-simpSingleton [subst0] = do-        subst <- freshToFree subst0-        return (Just (Just subst, []))-simpSingleton _        = return Nothing----- | If all substitutions @si@ map a variable @v@ to terms with the same---   outermost function symbol @f@, then they all contain the common factor---   @{v |-> f(x1,..,xk)}@ for fresh variables xi and we can replace---   @x |-> ..@ by @{x1 |-> ti1, x2 |-> ti2, ..}@ in all substitutions @si@.-simpAbstractFun :: MonadFresh m-                => [LNSubstVFresh]-                -> m (Maybe (Maybe LNSubst, [S.Set LNSubstVFresh]))-simpAbstractFun []             = return Nothing-simpAbstractFun (subst:others) = case commonOperators of-    [] -> return Nothing-    -- abstract all arguments-    (v, o, argss@(args:_)):_ | all ((==length args) . length) argss -> do-        fvars <- mapM (\_ -> freshLVar "x" LSortMsg) args-        let substs' = zipWith (abstractAll v fvars) (subst:others) argss-            fsubst  = substFromList [(v, fApp o (map varTerm fvars))]-        return $ Just (Just fsubst, [S.fromList substs'])-    -- abstract first two arguments-    (v, o@(AC _), argss):_ -> do-        fv1 <- freshLVar "x" LSortMsg-        fv2 <- freshLVar "x" LSortMsg-        let substs' = zipWith (abstractTwo o v fv1 fv2) (subst:others) argss-            fsubst  = substFromList [(v, fApp o (map varTerm [fv1,fv2]))]-        return $ Just (Just fsubst, [S.fromList substs'])-    (_, _ ,_):_ ->-        error "simpAbstract: impossible, invalid arities or List operator encountered."-  where-    commonOperators = do-        (v, viewTerm -> FApp o args) <- substToListVFresh subst-        let images = map (\s -> imageOfVFresh s v) others-            argss  = [ args' | Just (viewTerm -> FApp o' args') <- images, o' == o ]-        guard (length argss == length others)-        return (v, o, args:argss)--    abstractAll v freshVars s args = substFromListVFresh $-        filter ((/= v) . fst) (substToListVFresh s) ++ zip freshVars args--    abstractTwo o v fv1 fv2 s args = substFromListVFresh $-        filter ((/= v) . fst) (substToListVFresh s) ++ newMappings args-      where-        newMappings []      =-            error "simpAbstract: impossible, AC symbols must have arity >= 2."-        newMappings [a1,a2] = [(fv1, a1), (fv2, a2)]-        -- here we always abstract from left to right and do not-        -- take advantage of the AC property of o-        newMappings (a:as)  = [(fv1, a),  (fv2, fApp o as)]----- | If all substitutions @si@ map a variable @v@ to the same name @n@,---   then they all contain the common factor ---   @{v |-> n}@ and we can remove @{v -> n} from all substitutions @si@-simpAbstractName :: MonadFresh m-                 => [LNSubstVFresh]-                 -> m (Maybe (Maybe LNSubst, [S.Set LNSubstVFresh]))-simpAbstractName []             = return Nothing-simpAbstractName (subst:others) = case commonNames of-    []           -> return Nothing-    (v, c):_     ->-        return $ Just (Just $ substFromList [(v, c)]-                      , [S.fromList (map (\s -> restrictVFresh (delete v (domVFresh s)) s) (subst:others))])-  where-    commonNames = do-        (v, c@(viewTerm -> Lit (Con _))) <- substToListVFresh subst-        let images = map (\s -> imageOfVFresh s v) others-        guard (length images == length [ () | Just c' <- images, c' == c])-        return (v, c)----- | If all substitutions @si@ map a variable @v@ to variables @xi@ of the same---   sort @s@ then they all contain the common factor ---   @{v |-> y}@ for a fresh variable of sort @s@---   and we can replace @{v -> xi}@ by @{y -> xi} in all substitutions @si@-simpAbstractSortedVar :: MonadFresh m-                      => [LNSubstVFresh]-                      -> m (Maybe (Maybe LNSubst, [S.Set LNSubstVFresh]))-simpAbstractSortedVar []             = return Nothing-simpAbstractSortedVar (subst:others) = case commonSortedVar of-    []            -> return Nothing-    (v, s, lvs):_ -> do-        fv <- freshLVar (lvarName v) s-        return $ Just (Just $ substFromList [(v, varTerm fv)]-                      , [S.fromList (zipWith (replaceMapping v fv) lvs (subst:others))])-  where-    commonSortedVar = do-        (v, (viewTerm -> Lit (Var lx))) <- substToListVFresh subst-        guard (sortCompare (lvarSort v)  (lvarSort lx) == Just GT)-        let images = map (\s -> imageOfVFresh s v) others-            -- FIXME: could be generalized to choose topsort s of all images if s < sortOf v-            --        could also be generalized to terms of a given sort-            goodImages = [ ly | Just (viewTerm -> Lit (Var ly)) <- images, lvarSort lx == lvarSort ly]-        guard (length images == length goodImages)-        return (v, lvarSort lx, (lx:goodImages))-    replaceMapping v fv lv sigma =-        substFromListVFresh $ (filter ((/=v) . fst) $ substToListVFresh sigma) ++ [(fv, varTerm lv)]---- | If all substitutions @si@ map two variables @x@ and @y@ to identical terms @ti@,---   then they all contain the common factor @{x |-> y} for a fresh variable @z@---   and we can remove @{x |-> ti}@ from all @si@.-simpIdentify :: MonadFresh m-             => [LNSubstVFresh]-             -> m (Maybe (Maybe LNSubst, [S.Set LNSubstVFresh]))-simpIdentify []             = return Nothing-simpIdentify (subst:others) = case equalImgPairs of-    []         -> return Nothing-    ((v,v'):_) -> do-        let (vkeep, vremove) = case sortCompare (lvarSort v) (lvarSort v') of-                                 Just GT -> (v', v)-                                 Just _  -> (v, v')-                                 Nothing -> error $ "EquationStore.simpIdentify: impossible, variables with incomparable sorts: "-                                                    ++ show v ++" and "++ show v'-        return $ Just (Just  (substFromList [(vremove, varTerm vkeep)]),-                       [S.fromList (map (removeMappings [vkeep]) (subst:others))])-  where-    equalImgPairs = do-        (v,t)    <- substToListVFresh subst-        (v', t') <- substToListVFresh subst-        guard (t == t' && v < v' && all (agrees_on v v') others)-        return (v,v')-    agrees_on v v' s =-        imageOfVFresh s v == imageOfVFresh s v' && isJust (imageOfVFresh s v)-    removeMappings vs s = restrictVFresh (domVFresh s \\ vs) s----- | Simplify by removing substitutions that occur twice in a disjunct.---   We could generalize this function by using AC-equality or subsumption.-simpMinimize :: MonadFresh m => (LNSubstVFresh -> Bool) -> StateT EqStore m Bool-simpMinimize isContr = do-    conj <- MS.gets (get eqsConj)-    if F.any (S.foldr (\subst b -> subst == emptySubstVFresh || isContr subst || b) False) conj-        then MS.modify (set eqsConj (fmap minimize conj)) >> return True-        else return False-  where minimize substs-            | emptySubstVFresh `S.member` substs = S.singleton emptySubstVFresh-            | otherwise                          = S.filter (not . isContr) substs----- | Traverse disjunctions and execute @f@ until it returns---   @Just (mfreeSubst, disjs)@.---   Then the @disjs@ is inserted at the current position, if @mfreeSubst@ is---   @Just freesubst@, then it is applied to the equation store. @True@ is---   returned if any modifications took place.-foreachDisj :: MonadFresh m-            => MaudeHandle-            -> ([LNSubstVFresh] -> m (Maybe (Maybe LNSubst, [S.Set LNSubstVFresh])))-            -> StateT EqStore m Bool-foreachDisj hnd f =-    go [] =<< gets (getConj . get eqsConj)-  where-    go _     []         = return False-    go lefts (d:rights) = do-        b <- lift $ f (S.toList d)-        case b of-          Nothing              -> go (d:lefts) rights-          Just (msubst, disjs) -> do-              MS.modify (set eqsConj (Conj (reverse lefts ++ disjs ++ rights)))-              maybe (return ()) (\s -> MS.modify (applyEqStore hnd s)) msubst-              return True
− src/Theory/Proof/Guarded.hs 
@@ -1,566 +0,0 @@-{-# LANGUAGE TypeOperators, TemplateHaskell, DeriveDataTypeable, ScopedTypeVariables, TupleSections-             , StandaloneDeriving, TypeSynonymInstances, BangPatterns, FlexibleInstances, FlexibleContexts #-}--- |--- Copyright   : (c) 2011 Benedikt Schmidt & Simon Meier--- License     : GPL v3 (see LICENSE)--- --- Maintainer  : Benedikt Schmidt <beschmi@gmail.com>--- Portability : GHC only------ Guarded Formulas.-module Theory.Proof.Guarded (--  -- * Guarded logical formulas-    Guarded(..)-  , LGuarded-  , LNGuarded-  -  -- ** Formula Construction-  , gfalse-  , gtrue-  , gdisj-  , gconj--  -- ** Traversals-  , mapGuardedAtoms--  -- ** Conversions to non-bound representations-  , fromFormula-  , fromFormulaNegate-  , bvarToLVar--  -- ** Induction-  , applyInduction-  , negateGuarded--  -- ** Queries-  , isConjunction-  , isDisjunction-  , isAllGuarded-  , isExGuarded--  -- ** Opening quantifiers-  , openExGuarded-  , openAllGuarded--  -- ** Substitutions-  , substBound-  , substBoundAtom-  , substFree-  , substFreeAtom--  -- ** Pretty-printing-  , prettyGuarded--  ) where--import Control.Applicative-import Control.Monad.Error-import Control.DeepSeq--import Data.Traversable hiding ( mapM, sequence )-import Data.List-import Data.Monoid   (mappend, mconcat)-import Data.Foldable (Foldable(..), foldMap)-import Data.Either   (partitionEithers)-import Data.DeriveTH-import Data.Binary---import Theory.Rule-import Logic.Connectives-import Theory.Atom-import Theory.Formula--import Text.PrettyPrint.Highlight--import Control.Monad.Fresh hiding ( mapM )-import Control.Arrow------------------------------------------------------------------------------------ Types---------------------------------------------------------------------------------data Guarded s c v = GAto  (Atom (VTerm c (BVar v)))-                   | GDisj (Disj (Guarded s c v))-                   | GConj (Conj (Guarded s c v))-                   | GGuarded Quantifier [s] [Atom (VTerm c (BVar v))] (Guarded s c v)-                    -- ^ Denotes @ALL xs. as => gf@ or @Ex xs. as & gf&-                    -- depending on the 'Quantifier'.-                    -- We assume that all bound variables xs occur in-                    -- f@i atoms in as.-                   deriving (Eq, Ord, Show)--isConjunction :: Guarded t t1 t2 -> Bool-isConjunction (GConj _)  = True-isConjunction _          = False--isDisjunction :: Guarded t t1 t2 -> Bool-isDisjunction (GDisj _)  = True-isDisjunction _          = False--isExGuarded :: Guarded t t1 t2 -> Bool-isExGuarded (GGuarded Ex _ _ _) = True-isExGuarded _                   = False--isAllGuarded :: Guarded t t1 t2 -> Bool-isAllGuarded (GGuarded All _ _ _) = True-isAllGuarded _                    = False----------------------------------------------------------------------------------- Folding----------------------------------------------------------------------------------- | Fold a guarded formula.-foldGuarded :: (Atom (VTerm c (BVar v)) -> b)-            -> (Disj b -> b)-            -> (Conj b -> b)-            -> (Quantifier -> [s] -> [Atom (VTerm c (BVar v))] -> b -> b)-            -> Guarded s c v-            -> b-foldGuarded fAto fDisj fConj fGuarded =-  go- where-  go (GAto a)                = fAto a-  go (GDisj disj)            = fDisj $ fmap go disj-  go (GConj conj)            = fConj $ fmap go conj-  go (GGuarded qua ss as gf) = fGuarded qua ss as (go gf)---- | Fold a guarded formula with scope info.--- The Integer argument denotes the number of--- quantifiers that have been encountered so far.-foldGuardedScope :: (Integer -> Atom (VTerm c (BVar v)) -> b)-                 -> (Disj b -> b)-                 -> (Conj b -> b)-                 -> (Quantifier -> [s] -> Integer -> [Atom (VTerm c (BVar v))] -> b -> b)-                 -> Guarded s c v-                 -> b-foldGuardedScope fAto fDisj fConj fGuarded =-  go 0- where-  go !i (GAto a)            = fAto i a-  go !i (GDisj disj)        = fDisj $ fmap (go i) disj-  go !i (GConj conj)        = fConj $ fmap (go i) conj-  go !i (GGuarded qua ss as gf) =-    fGuarded qua ss i' as (go i' gf)-   where-    i' = i + fromIntegral (length ss)----- | Map a guarded formula with scope info.--- The Integer argument denotes the number of--- quantifiers that have been encountered so far.-mapGuardedAtoms :: (Integer -> Atom (VTerm c (BVar v))-                -> Atom (VTerm d (BVar w)))-                -> Guarded s c v-                -> Guarded s d w-mapGuardedAtoms f = -    foldGuardedScope (\i a -> GAto $ f i a) GDisj GConj-                     (\qua ss i as gf -> GGuarded qua ss (map (f i) as) gf) ----------------------------------------------------------------------------------- Instances---------------------------------------------------------------------------------{--instance Functor (Guarded s c) where-    fmap f = foldGuarded (GAto . fmap (fmapTerm (fmap (fmap f)))) GDisj GConj-                         (\qua ss as gf -> GGuarded qua ss (map (fmap (fmapTerm (fmap (fmap f)))) as) gf)--}--instance Foldable (Guarded s c) where-    foldMap f = foldGuarded (foldMap (foldMap (foldMap (foldMap f))))-                            (mconcat . getDisj)-                            (mconcat . getConj)-                            (\_qua _ss as b -> foldMap (foldMap (foldMap (foldMap (foldMap f)))) as `mappend` b)--traverseGuarded :: (Applicative f, Ord c, Ord v, Ord a)-                => (a -> f v) -> Guarded s c a -> f (Guarded s c v)-traverseGuarded f = foldGuarded (liftA GAto . traverse (traverseTerm (traverse (traverse f))))-                                (liftA GDisj . sequenceA)-                                (liftA GConj . sequenceA)-                                (\qua ss as gf -> GGuarded qua ss <$> traverse (traverse (traverseTerm (traverse (traverse f)))) as <*> gf)--instance Ord c => HasFrees (Guarded (String, LSort) c LVar) where-    foldFrees f = foldMap  (foldFrees f)-    mapFrees  f = traverseGuarded (mapFrees f)----- FIXME: remove name hints for variables for saturation?-type LGuarded c = Guarded (String, LSort) c LVar----------------------------------------------------------------------------------- Substitutions of bound for free and vice versa----------------------------------------------------------------------------------- | @substBoundAtom s a@ substitutes each occurence of a bound variables @i@--- in @dom(s)@ with the corresponding free variable @x=s(i)@ in the atom @a@.-substBoundAtom :: Ord c => [(Integer,LVar)] -> Atom (VTerm c (BVar LVar)) -> Atom (VTerm c (BVar LVar))-substBoundAtom s = fmap (fmapTerm (fmap subst))- where subst bv@(Bound i') = case lookup i' s of-                               Just x -> Free x-                               Nothing -> bv-       subst fv            = fv---- | @substBound s gf@ substitutes each occurence of a bound--- variable @i@ in @dom(s)@ with the corresponding free variable--- @s(i)=x@ in all atoms in @gf@.-substBound :: Ord c => [(Integer,LVar)] -> LGuarded c -> LGuarded c-substBound s = mapGuardedAtoms (\j a -> substBoundAtom [(i+j,v) | (i,v) <- s] a)----- | @substFreeAtom s a@ substitutes each occurence of a free variables @v@--- in @dom(s)@ with the bound variables @i=s(v)@ in the atom @a@.-substFreeAtom :: Ord c-              => [(LVar,Integer)] -              -> Atom (VTerm c (BVar LVar)) -> Atom (VTerm c (BVar LVar))-substFreeAtom s = fmap (fmapTerm (fmap subst))- where subst fv@(Free x) = case lookup x s of-                               Just i -> Bound i-                               Nothing -> fv-       subst bv          = bv---- | @substFreeAtom s gf@ substitutes each occurence of a free variables--- @v in dom(s)@ with the correpsonding bound variables @i=s(v)@--- in all atoms in  @gf@.-substFree :: Ord c => [(LVar,Integer)] -> LGuarded c -> LGuarded c-substFree s = mapGuardedAtoms (\j a -> substFreeAtom [(v,i+j) | (v,i) <- s] a)---- | Assuming that there are no more bound variables left in an atom of a--- formula, convert it to an atom with free variables only.-bvarToLVar :: Ord c => Atom (VTerm c (BVar LVar)) -> Atom (VTerm c LVar)-bvarToLVar = -    fmap (fmapTerm (fmap (foldBVar boundError id)))-  where-    boundError v = error $ "bvarToLVar: left-over bound variable '" -                           ++ show v ++ "'"----------------------------------------------------------------------------------- Opening and Closing----------------------------------------------------------------------------------- | @openGuarded gf@ returns @Just (qua,vs,ats,gf')@ if @gf@ is a guarded--- clause and @Nothing@ otherwise. In the first case, @quao@ is the quantifier,--- @vs@ is a list of fresh variables, @ats@ is the antecedent, and @gf'@ is the--- succedent. In both antecedent and succedent, the bound variables are--- replaced by @vs@.-openGuarded :: (Ord c, MonadFresh m)-            => LGuarded c -> m (Maybe (Quantifier, [LVar], [Atom (VTerm c LVar)], LGuarded c))-openGuarded (GGuarded qua vs as gf) = do-    xs <- mapM (\(n,s) -> freshLVar n s) vs-    return $ Just (qua, xs, openas xs, opengf xs)-  where -    openas xs = map (bvarToLVar . substBoundAtom (subst xs)) as-    opengf xs = substBound (subst xs) gf-    subst xs  = zip [0..] (reverse xs)-openGuarded _ = return Nothing---- | @closeGuarded vs ats gf@ is a smart constructor for @GGuarded@.-closeGuarded :: Ord c => Quantifier -> [LVar] -> [Atom (VTerm c LVar)] -             -> LGuarded c -> LGuarded c-closeGuarded qua vs as gf = GGuarded qua vs' as' gf'- where as' = map (substFreeAtom s . fmap (fmapTerm (fmap Free))) as-       gf' = substFree s gf-       s   = zip (reverse vs) [0..]-       vs' = map (lvarName &&& lvarSort) vs---- | @openAllGuarded gf@ returns @Just (vs,ats,gf')@ if @gf@ is a guarded--- all quantified trace formula and @Nothing@ otherwise. In the first case,--- @vs@ is a list of fresh variables, @ats@ is the antecedent, and @gf'@ is--- the succedent. In both antecedent and succedent, the bound variables are--- replaced by @vs@.-openAllGuarded :: (Ord c, MonadFresh m)-               => LGuarded c -> m (Maybe ([LVar],[Atom (VTerm c LVar)], LGuarded c))-openAllGuarded = (fmap adapt) . openGuarded-  where-    adapt (Just (All, vs, as, gf)) = Just (vs, as, gf)-    adapt _                        = Nothing---- | @openExGuarded gf@ returns @Just (vs,gf')@ if @gf@ is a guarded--- existentially quantified trace formula and @Nothing@ otherwise. In the--- first case, @vs@ is a list of fresh variables and @gf'@ is the body of @gf@--- with the bound variable replaced by @v@.-openExGuarded :: (MonadFresh m, Eq c, Ord c) -             => LGuarded c -> m (Maybe ([LVar], LGuarded c))-openExGuarded (GGuarded Ex ss as gf0) = do-    xs <- mapM (uncurry freshLVar) ss-    return $ Just (xs, substBound (zip [0..] (reverse xs)) gf)-  where -    gf = gconj (map GAto as ++ [gf0])-openExGuarded _ = return Nothing------------------------------------------------------------------------------------ Conversion and negation----------------------------------------------------------------------------------- | @fromFormulaNegate f@ returns a guarded formula @gf@ that is--- equivalent to @f@ if possible.-fromFormula :: LNFormula  -> Either String LNGuarded-fromFormula = convert False---- | @fromFormulaNegate f@ returns a guarded formula @gf@ that is--- equivalent to @not f@ if possible.-fromFormulaNegate :: LNFormula  -> Either String LNGuarded-fromFormulaNegate = convert True--type LNGuarded = Guarded (String,LSort) Name LVar---- | @gtf b@ returns the guarded formula f with @b <-> f@.-gtf :: Bool -> Guarded s c v-gtf False = GDisj (Disj [])-gtf True  = GConj (Conj [])---- | @gfalse@ returns the guarded formula f with @False <-> f@.-gfalse :: Guarded s c v-gfalse = gtf False---- | @gtrue@ returns the guarded formula f with @True <-> f@.-gtrue :: Guarded s c v-gtrue = gtf True---- | @gnot a@ returns the guarded formula f with @not a <-> f@.-gnot :: Atom (VTerm c (BVar v)) -> Guarded s c v-gnot a  = GGuarded All [] [a] gfalse--- FIXME: This was the old code. However, it should be necessary to quantify--- the frees, as we are working in a closed formula always.--- gnot a  = GGuarded All (map (lvarName &&& lvarSort) $ frees a) [a] gfalse---- | @gconj gfs@ smart constructor for the conjunction of gfs.-gconj :: (Eq s, Eq c, Eq v) => [Guarded s c v] -> Guarded s c v-gconj gfs0 = case concatMap flatten gfs0 of -    [gf]                      -> gf-    gfs | any (gfalse ==) gfs -> gfalse-        | otherwise           -> GConj $ Conj $ nub gfs-  where-    flatten (GConj conj) = concatMap flatten $ getConj conj-    flatten gf           = [gf]---- | @gdisj gfs@ smart constructor for the disjunction of gfs.-gdisj :: (Eq s, Eq c, Eq v) => [Guarded s c v] -> Guarded s c v-gdisj gfs0 = case concatMap flatten gfs0 of-    [gf]                     -> gf-    gfs | any (gtrue ==) gfs -> gtrue-        | otherwise          -> GDisj $ Disj $ nub gfs-  where-    flatten (GDisj disj) = concatMap flatten $ getDisj disj-    flatten gf           = [gf]---- @ A smart constructor for @GGuarded Ex@ that removes empty quantifications.-gex :: (Eq s, Eq c, Eq v)-    => [s] -> [Atom (VTerm c (BVar v))] -> Guarded s c v -> Guarded s c v-gex [] as gf = gconj (map GAto as ++ [gf])-gex ss as gf = GGuarded Ex ss as gf---- @ A smart constructor for @GGuarded All@ that does nothing special--- (currently).-gall :: [s] -> [Atom (VTerm c (BVar v))] -> Guarded s c v -> Guarded s c v-gall = GGuarded All---- | @convert neg f@ returns @Nothing@ if @f@ cannot be converted,--- @Just gf@ such that @mneg f <-> gf@ with @mneg = id@ if @neg@ is @False@--- and @mneg=not@ if @neg@ is true.-convert :: Bool -> LNFormula  -> Either String LNGuarded-convert True  (Ato a) = pure $ gnot a-convert False (Ato a) = pure $ GAto a--convert polarity (Not f) = convert (not polarity) f--convert True  (Conn And f g) = gdisj <$> mapM (convert True)  [f, g]-convert False (Conn And f g) = gconj <$> mapM (convert False) [f, g]--convert True  (Conn Or f g)  = gconj <$> mapM (convert True)  [f, g]-convert False (Conn Or f g)  = gdisj <$> mapM (convert False) [f, g]--convert True  (Conn Imp f g         ) = -    gconj <$> sequence [convert False f, convert True  g]-convert False (Conn Imp f g         ) = -    gdisj <$> sequence [convert True  f, convert False g]--convert polarity    (TF b) = pure $ gtf (polarity /= b)--convert polarity f0@(Qua qua0 _ _) =-    -- The quantifier switch stems from our implicit negation of the formula.-    case (qua0, polarity) of-      (All, True ) -> convAll Ex-      (All, False) -> convAll All-      (Ex,  True ) -> convEx  All-      (Ex,  False) -> convEx  Ex-  where-    convEx qua = do-      (xs,_,f) <- openFormulaPrefix f0 `evalFreshT` avoid f0-      case partitionEithers $ partitionConj f of-        (as, fs) -> do-          let guardedvars = frees as-              -- all existentially quantified variables must be guarded-              unguarded = xs \\ guardedvars--          unless (null unguarded) $ throwError $ -              "unguarded variables " ++ show unguarded ++ " in " ++ show f0-         -          gf <- (if polarity then gdisj else gconj)-                  <$> mapM (convert polarity) fs-          return $ closeGuarded qua xs as gf-      where-        partitionConj (Conn And f1 f2)     = partitionConj f1 ++ partitionConj f2-        partitionConj (Ato a@(Action _ _)) = [Left $ bvarToLVar a]-        partitionConj (Ato e@(EqE _ _))    = [Left $ bvarToLVar e]-        partitionConj f                    = [Right f]--    convAll qua = do-      (xs,_,f) <- openFormulaPrefix f0 `evalFreshT` avoid f0-      case f of-        Conn Imp ante suc -> do-          allowedAtoms <- collectAllowedAtoms ante--          let guardedvars = frees [ a | a@(Action _ _) <- allowedAtoms ]-              -- all universally quantified variables must be guarded-              unguarded = xs \\ guardedvars--          when (not $ null unguarded) $ throwError $-              "unguarded variables " ++ show unguarded ++ " in " ++ show f0--          g <- convert polarity suc-          return $ closeGuarded qua xs allowedAtoms g--        _ -> throwError $ show f ++ "outside guarded fragment"-     where-      collectAllowedAtoms (Conn And f1 f2)     =-        (++) <$> collectAllowedAtoms f1 <*> collectAllowedAtoms f2-      collectAllowedAtoms (Ato a@(Action _ _)) = return [bvarToLVar a]-      collectAllowedAtoms (Ato e@(EqE _ _))    = return [bvarToLVar e]-      collectAllowedAtoms na                   = -        throwError $ show na ++ " not allowed in antecedent"--convert _     (Conn Iff _ _) =-  Left $ "`iff' not supported (yet)"--instance Apply LNGuarded where-  apply subst = mapGuardedAtoms (const $ apply subst)------------------------------------------------------------------------------------ Induction over the trace----------------------------------------------------------------------------------- Note that we assume that the guarded formula describes the attack.--- Hence, we want to show that it is false.--{---- | Checks if a doubly guarded formula is last-free; i.e., does not contain a 'Last'--- atom.-lastFree :: Guarded s c v -> Bool-lastFree = error "lastFree: implement"---- | Checks if a formula is doubly guarded; i.e., both universal and existential--- quantifiers are guarded.-doublyGuarded :: Guarded s c v -> Bool-doublyGuarded = either (const False) (const True) . satisfiedByEmptyTrace--}---- | Negate a guarded formula.-negateGuarded :: (Eq s, Eq c, Eq v) -              => Guarded s c v -> Guarded s c v-negateGuarded = -    go-  where-    go (GGuarded All ss as gf) = gex  ss as $ go gf-    go (GGuarded Ex ss as gf)  = gall ss as $ go gf-    go (GAto ato)              = gnot ato-    go (GDisj disj)            = gconj $ map go (getDisj disj)-    go (GConj conj)            = gdisj $ map go (getConj conj)----- | Checks if a doubly guarded formula is satisfied by the empty trace;--- returns @'Left' errMsg@ if the formula is not doubly guarded.-satisfiedByEmptyTrace :: Guarded s c v -> Either String Bool-satisfiedByEmptyTrace = -  foldGuarded -    (\_ato -> throwError "atom outside the scope of a quantifier")-    (liftM or  . sequence . getDisj) -    (liftM and . sequence . getConj)-    (\qua _ss _as _gf -> return $ qua == All)  -    -- the empty trace always satisfies guarded all-quantification-    -- and always dissatisfies guarded ex-quantification---- | Tries to convert a doubly guarded formula to an induction hypothesis.--- Returns @'Left' errMsg@ if the formula is not last-free or not doubly--- guarded.-toInductionHypothesis :: Eq c => LGuarded c -> Either String (LGuarded c)-toInductionHypothesis =-    go-  where-    go (GGuarded qua ss as gf) = do-        gf' <- go gf-        return $ case qua of-          All -> GGuarded Ex  ss as (gconj $ (gnot <$> lastAtos) ++ [gf'])-          Ex  -> GGuarded All ss as (gdisj $ (GAto <$> lastAtos) ++ [gf'])-        -      where-        lastAtos :: [Atom (VTerm c (BVar LVar))]-        lastAtos = do-            (j, (_, LSortNode)) <- zip [0..] $ reverse ss-            return $ Last (varTerm (Bound j))--    go (GAto (Less i j)) = return $ gdisj [GAto (EqE i j), GAto (Less j i)]-    go (GAto (Last _))   = throwError "formula not last-free"-    go (GAto ato)        = return $ gnot ato-    go (GDisj disj)      = gconj <$> traverse go (getDisj disj)-    go (GConj conj)      = gdisj <$> traverse go (getConj conj)---- | Try to prove the formula by applying induction over the trace.--- Returns @'Left' errMsg@ if this is not possible.-applyInduction :: Eq c => LGuarded c -> Either String (LGuarded c)-applyInduction gf = do-    baseCase <- satisfiedByEmptyTrace gf-    if baseCase-      then throwError "cannot apply induction: empty trace is an attack"-      else do-        gfIH <- toInductionHypothesis gf-        return (gconj [gf, gfIH])------------------------------------------------------------------------------------ Pretty Printing----------------------------------------------------------------------------------- | Pretty print a formula.-prettyGuarded :: HighlightDocument d -              => LNGuarded      -- ^ Guarded Formula.-              -> d              -- ^ Pretty printed formula.-prettyGuarded f = -    pp f `evalFreshAvoiding` f-  where-    pp :: HighlightDocument d => LNGuarded -> Fresh d-    pp (GAto a) = return $ prettyNAtom $ bvarToLVar a--    pp (GDisj (Disj [])) = return $ operator_ "F"--    pp (GDisj (Disj xs)) = do-        ps <- mapM (\x -> opParens <$> pp x) xs-        return $ sep $ punctuate (operator_ " |") ps--    pp (GConj (Conj [])) = return $ operator_ "T"--    pp (GConj (Conj xs)) = do-        ps <- mapM (\x -> opParens <$> pp x) xs-        return $ sep $ punctuate (operator_ " &") ps--    pp gf0@(GGuarded _ _ _ _) = do-      Just (qua, vs, atoms, gf) <- openGuarded gf0-      dante <- pp (GConj (Conj (map (GAto . fmap (fmapTerm (fmap Free))) atoms)))-      dsucc <- pp gf-      return $ sep [ operator_ (show qua) <-> ppVars vs <> operator_ "."-                   , nest 1 dante-                   , operator_ (case qua of All -> "==>"; Ex -> "&")-                   , nest 1 dsucc]-      where-        ppVars       = fsep . map (text . show)----- Derived instances-----------------------$( derive makeBinary ''Guarded)-$( derive makeNFData ''Guarded)
− src/Theory/Proof/Sequent.hs 
@@ -1,1106 +0,0 @@-{-# LANGUAGE ViewPatterns, DeriveDataTypeable, TupleSections, TypeOperators, TemplateHaskell, TypeSynonymInstances, FlexibleInstances, FlexibleContexts, GeneralizedNewtypeDeriving #-}--- |--- Copyright   : (c) 2010-2012 Benedikt Schmidt & Simon Meier--- License     : GPL v3 (see LICENSE)------ Maintainer  : Simon Meier <iridcode@gmail.com>--- Portability : GHC only------ Proof states and their transformations; i.e., logical deduction.-module Theory.Proof.Sequent (-  -- * Sequent construction-    sequentFromFormula--  -- * Prove methods--  -- ** SeProof monad-  , SeProof-  , execSeProof-  , runSeProof-  , getMaudeHandle--  -- ** Goals-  , openGoals-  , solveGoal--  -- ** Equalitiy solving-  , solveSubstEqs--  -- ** Conjunction with other sequents-  , conjoinSequent--  -- ** Simplification-  , simplifySequent--  -- * Contradiction-  , proveCyclic-  , hasNonNormalTerms-  , hasForbiddenExp-  , formulasFalse-  , nonUniqueFactInstances-  , contradictorySequent--  -- * Convenience export of used modules-  , module Theory.Proof.Types-  , module Theory.Proof.EquationStore-  ) where--import           Debug.Trace--import           Prelude hiding ( (.), id )--import           Data.List-import           Data.Either-import qualified Data.DAG.Simple  as D (cyclic, reachableSet)-import qualified Data.Set         as S-import qualified Data.Map         as M-import           Data.Monoid (Monoid, mappend )--import           Control.Basics-import           Control.Category-import           Control.Monad.Disj-import           Control.Monad.Reader-import           Control.Monad.Bind-import           Control.Monad.State (StateT, runStateT, execStateT, gets, put)--import           Text.PrettyPrint.Class--import           Extension.Prelude-import           Extension.Data.Label--import           Logic.Connectives--import           Theory.Rule-import           Theory.Proof.SolveGuarded-import           Theory.Proof.Types-import           Theory.Proof.EquationStore--import           Term.Rewriting.Norm (nf', maybeNotNfSubterms)----------------------------------------------------------------------------------- Sequents----------------------------------------------------------------------------------- Construction-------------------- | Returns the sequent that has to be proven to show that---   given formula holds in the context of the given theory.-sequentFromFormula :: CaseDistKind -> SequentTraceQuantifier -> LNFormula -> Sequent-sequentFromFormula kind traceQuantifier f = -    set sFormulas (S.singleton gf) (emptySequent kind)-  where -    adapt = case traceQuantifier of-      ExistsSomeTrace -> negateGuarded-      ExistsNoTrace   -> id-    gf = either error id (adapt <$> fromFormulaNegate f)------------------------------------------------------------------------------------ Graph reasoning----------------------------------------------------------------------------------- | True iff there are terms in the node constraints that are not in normal form wrt.--- to 'Term.Rewriting.Norm.norm' (DH/AC).-hasNonNormalTerms :: SignatureWithMaude -> Sequent -> Bool-hasNonNormalTerms sig se =-    any (not . (`runReader` hnd) . nf') (maybeNonNormalTerms hnd se)-  where hnd = get sigmMaudeHandle sig---- | Returns all (sub)terms of node constraints that may be not in normal form.-maybeNonNormalTerms :: MaudeHandle -> Sequent -> [LNTerm]-maybeNonNormalTerms hnd se = -    sortednub . concatMap getTerms . M.elems . get sNodes $ se-  where getTerms (Rule _ ps cs as) = do-          f <- ps++cs++as-          t <- factTerms f-          maybeNotNfSubterms (mhMaudeSig hnd) t--substCreatesNonNormalTerms :: MaudeHandle -> Sequent -> LNSubstVFresh -> Bool-substCreatesNonNormalTerms hnd se =-    \subst -> any (not . nfApply subst) terms-  where terms = maybeNonNormalTerms hnd se-        nfApply subst0 t = t == t'  || nf' t' `runReader` hnd-          where tvars = freesList t-                subst = restrictVFresh tvars subst0-                t'  = apply (freshToFreeAvoidingFast subst tvars) t---- | True if there is no @EXP-down@ rule that should be replaced by an--- @EXP-up@ rule.-hasForbiddenExp :: Sequent -> Bool-hasForbiddenExp se =-    any (isForbiddenExp) $ M.elems $ get sNodes se---- | @isForbiddenExp ru@ returns @True@ if @ru@ is not allowed in--- a normal dependency graph.--- > isForbiddenExp (Rule () [undefined, Fact KUFact [undefined, Mult (Inv x1) x2]]---                           [Fact KDFact [expTagToTerm IsExp, Exp p1 (Mult x2 x3)]] [])--- > False--- > isForbiddenExp (Rule () [undefined, Fact KUFact [undefined, Mult (Inv x1) x2]]---                           [Fact KDFact [expTagToTerm IsExp, Exp p1 x2]] [])--- > True-isForbiddenExp :: Rule a -> Bool-isForbiddenExp ru = maybe False id $ do-    [_,p2] <- return $ get rPrems ru-    [conc] <- return $ get rConcs ru-    (UpK, _,          b) <- kFactView p2-    (DnK, Just CannotExp, viewTerm2 -> FExp g c) <- kFactView conc--    -- g should be public and the required inputs for c already required by b-    guard (sortOfTerm g == LSortPub && (input c \\ input b == []))-    return True-  where-    sortOfTerm (viewTerm -> Lit (Var lv)) = lvarSort lv-    sortOfTerm (viewTerm -> Lit (Con n))  = sortOfName n-    sortOfTerm _                          = LSortMsg----- | Compute all contradictions to unique fact instances.------ Constraint systems are contradictory, where 'f' is a fact symbol--- with unique instances and temporal variables i, j, and k are ordered--- according to i < j < k, j requires a premise f(t), and i provides a--- conclusion f(t) for the node k. Graphically, the edge from i to k is--- interrupted by the node j that requires the same fact carried on the edge.-nonUniqueFactInstances :: SignatureWithMaude -> Sequent -                       -> [(NodeId, NodeId, NodeId)]-nonUniqueFactInstances sig se = do-    Edge c@(i, _) (k, _) <- S.toList $ get sEdges se-    let tag = factTag (nodeConcFact c se)-    guard (tag `S.member` get sigmUniqueInsts sig)-    j <- S.toList $ D.reachableSet [i] less--    let isCounterExample = (j /= i) && (j /= k) && -                           maybe False checkRule (M.lookup j $ get sNodes se)--        checkRule jRu    = any ((tag ==) . factTag) (get rPrems jRu) &&-                           k `S.member` D.reachableSet [j] less--    guard isCounterExample-    return (i, j, k) -- counter-example to unique fact instances-  where-    less = sRawLessRel se------ Under-approximating minimal deducability------------------------------------------------ | @proveCyclic se@ under-approximates @|se| ==> Ex v. v >+> v@.-proveCyclic :: Sequent -> Bool-proveCyclic = D.cyclic . sRawLessRel---- | @formulasFalse se@ returns @True@ if False is included in the formulas of @se@-formulasFalse :: Sequent -> Bool-formulasFalse = S.member gfalse . get sFormulas---- | @contradictorySequent se@ holds if the sequent is trivially contradictory.---   FIXME: duplication with contradictions in Proof-contradictorySequent :: SignatureWithMaude -> Sequent -> Bool-contradictorySequent sig se =-    formulasFalse se                              ||-    eqsIsFalse (get sEqStore se)                  ||-    proveCyclic se                                ||-    hasNonNormalTerms sig se                      ||-    hasForbiddenExp se                            ||-    not (null (nonUniqueFactInstances sig se))----- SeProof monad--------------------- | A proof with respect to a sequent. The fresh variables are existential--- variables of the sequent and the multiple results are to be interpreted as a--- disjunction while the inner-most maybe indicates if the proof method is--- applicable/was successful or not.-type SeProof = StateT Sequent (FreshT (DisjT (Reader ProofContext)))---- | Run a proof step.-runSeProof :: SeProof a -> ProofContext -> Sequent -> FreshState -           -> Disj ((a, Sequent), FreshState)-runSeProof m ctxt se fs = -    Disj $ (`runReader` ctxt) $ runDisjT $ (`runFreshT` fs) $ runStateT m se---- | Run a proof step, returning only the updated states.-execSeProof :: SeProof a -> ProofContext -> Sequent -> FreshState -            -> [(Sequent, FreshState)]-execSeProof m ctxt se fs = -    (`runReader` ctxt) . runDisjT . (`runFreshT` fs) $ execStateT m se---- | Retrieve the 'MaudeHandle' from the 'ProofContext'.-getMaudeHandle :: SeProof MaudeHandle-getMaudeHandle = get sigmMaudeHandle <$> askM pcSignature---- | Import a rule with fresh variables.-importRule :: MonadFresh m-           => RuleAC-           -> m (RuleACInst, Maybe RuleACConstrs)-importRule ru = someRuleACInst ru `evalBindT` noBindings---- | @proveLinearConc se (v,i)@ tries to prove that the @i@-th conclusion of node--- @v@ is a linear fact.-proveLinearConc :: Sequent -> NodeConc -> Bool-proveLinearConc se (v,i) =-    maybe False (isLinearFact . (get (rConc i))) $ M.lookup v $ get sNodes se---- | Create a node labelled with a fresh instance of one of the rules and solve--- it's fresh conditions immediatly.------ PRE: Node must not yet be labelled with a rule.-ruleNode :: NodeId -> [RuleAC] -> SeProof RuleACInst-ruleNode i rules = do-    (ru, mrconstrs) <- importRule =<< disjunctionOfList rules-    solveRuleConstraints mrconstrs-    modM sNodes (M.insert i ru)-    let inFacts = do-          (v, Fact InFact [m]) <- enumPrems ru-          return $ do-            j <- freshLVar "vf" LSortNode-            ruKnows <- mkISendRuleAC m-            modM sNodes (M.insert j ruKnows)-            modM sEdges (S.insert $ Edge (j, ConcIdx 0) (i, v))-    let freshFacts = do-          (v, Fact FreshFact [m]) <- enumPrems ru-          return $ do-            j <- freshLVar "vf" LSortNode-            modM sNodes (M.insert j (mkFreshRuleAC m))-            unless (isFreshVar m) $ do -                -- 'm' must be of sort fresh-                n <- varTerm <$> freshLVar "n" LSortFresh-                solveTermEqs SplitNow [Equal m n]-            modM sEdges (S.insert $ Edge (j, ConcIdx 0) (i,v))-    -- solve all Fr and In premises-    sequence_ inFacts-    sequence_ freshFacts-    return ru-  where-    mkISendRuleAC m = do-        faPrem <- kuFact Nothing m-        return $ Rule (IntrInfo (ISendRule))-                      [faPrem] [inFact m] [kLogFact m]--    mkFreshRuleAC m = Rule (ProtoInfo (ProtoRuleACInstInfo FreshRule []))-                           [] [freshFact m] []---- | Create a fresh node labelled with a fresh instance of one of the rules--- and solve it's 'Fr' and 'In' facts immediatly.-freshRuleNode :: [RuleAC] -> SeProof (NodeId, RuleACInst)-freshRuleNode rules = do-    i <- freshLVar "vr" LSortNode-    (,) i <$> ruleNode i rules---- | Generate a fresh coerce rule node; return node-index, premise, and--- conclusion.-freshCoerceRuleNode :: SeProof (LVar, (LNFact, LNFact))-freshCoerceRuleNode = do-    i <- freshLVar "vc" LSortNode-    x <- varTerm <$> freshLVar "x" LSortMsg-    v <- freshLVar "f_" LSortMsg-    let faPrem = Fact KDFact [varTerm v, x]-        faConc = Fact KUFact [varTerm v, x]-    modM sNodes (M.insert i (Rule (IntrInfo CoerceRule) [faPrem] [faConc] []))-    return (i, (faPrem, faConc))---- | Create a fresh node labelled with a fresh instance of one of the rules--- and return one of the conclusions.-freshRuleConc :: [RuleAC]-              -> SeProof (RuleACInst, NodeConc, LNFact)-freshRuleConc rules = do-    (i, ru) <- freshRuleNode rules-    (v, fa) <- disjunctionOfList $ enumConcs ru-    return (ru, (i, v), fa)---- | Insert the edges and ensure the equality between the facts--- at either end of the edge.-insertEdges :: [(NodeConc, LNFact, LNFact, NodePrem)] -> SeProof ()-insertEdges edges = do-    solveFactEqs SplitNow [ Equal fa1 fa2 | (_, fa1, fa2, _) <- edges ]-    modM sEdges (\es -> foldr S.insert es [ Edge c p | (c,_,_,p) <- edges])----- Simplification---------------------- | Repeatedly apply the following simplifications to the sequent:------   - merge nodes with equal instances of Fresh rules---   - remove sequents that violate the sort constraints---   - merge nodes marked as the last node---   - merge multiple rule labels of the same node---   - merge nodes with equal non-pair message conclusions---   - merge targets of multiple edges from a linear fact and---     sources of multiple incoming edges to the same fact.---   - solve Pub and Fresh goals---   - solve unique action atoms------ The simplification stops when the sequent doesn't change anymore.----simplifySequent :: SeProof ()-simplifySequent = do-    -- start simplification, indicating that some change happened-    go (0 :: Int) [True]-    -- ensure that the substitution is applied to the whole sequent-    substSequent-    exploitUniqueMsgOrder-  where-    go n changes0-      | not (or changes0) = return ()-      | otherwise        = do-          -- perform one simplification pass-          substSequent-          -- exploit uniqueness of 'Fresh' rule instances-          c1 <- exploitFreshUnique-          when c1 (substNodes >> return ())-          -- exploit that conclusions deriving the same message can be merged-          -- except for merging coerce nodes with non-coerce nodes.-          c2 <- exploitUniqueMsgConcs-          when c2 (substNodes >> return ())-          -- exploit the special properties of the last node-          c3 <- exploitLastNode-          when c3 (substNodes >> return ())--          c4 <- solveSimpleUpK-          substPart sEdges-          c5 <- exploitEdgeProps-          substPart sAtoms-          c6 <- solveUniqueActions -          substPart sFormulas-          substPart sSolvedFormulas-          c7 <- simplifyNegativeOrderings-          c8 <- saturateFormulas--          -- report on looping behaviour if necessary-          se <- gets id-          let changes = [c1, c2, c3, c4, c5, c6, c7, c8]-              traceLoop-                | n <= 10   = id-                | otherwise = -                      trace ("   simplify: " ++ show n ++ " " ++ show changes)-                    . trace (render $ prettySequent se)--          -- Repeat simplification, if there was some change in this step.-          traceLoop $ go (n + 1) changes----- | Saturate the formulas. Return True, if the sequent was changed.-saturateFormulas :: SeProof Bool-saturateFormulas = do-    se     <- gets id-    hnd    <- getMaudeHandle-    result <- saturateGuarded hnd se-    case result of-      Nothing         -> do return False-      Just (eqs, se') -> do put se'-                            solveTermEqs SplitNow eqs-                            return True----- | Solve premise goals that can be solved directly by exploiting special--- properties of normalized derivation graphs.------ Solve K-up premises can just be connected to already derived knowledge.----solveSimpleUpK :: SeProof Bool-solveSimpleUpK = do-    nodes <- M.toList <$> getM sNodes-    let (down, up) = partitionEithers $ do-            (i, ru)   <- nodes-            (v, fa)   <- enumConcs ru-            (d, _, m) <- maybe mzero return $ kFactView fa-            let tag = case d of UpK -> Right; DnK -> Left-            return $ tag (m, (d, fa, (i, v)))-        -- retain the up-entry if there are duplicates-        derived = M.fromList $ down ++ up--    goals <- gets (map snd . openPremiseGoals)-    or <$> mapM (trySolveGoal derived) goals-  where-    trySolveGoal derived (PremUpKG p m) = trySolveMessage derived m-            (\c _ -> modM sMsgEdges (S.insert (MsgEdge c p)))--    trySolveGoal derived (PremiseG p faPrem _mayLoop) = case kFactView faPrem of-        Just (UpK, _, m) -> trySolveMessage derived m-            -- For premise goals we have 'inp m == [m]'. We must insert a-            -- direct edge and ensure the equality wrt. an additional coerce-            -- node.-            (\c faConc -> insertEdges [(c, faConc, faPrem, p)])--        _                -> return False-    -- all other goals cannot be solved => the sequent doesn't change-    trySolveGoal _ _ = return False-    -    trySolveMessage derived m solveWith = case M.lookup m derived of-        Just (UpK, faConc, c) -> solveWith c faConc >> return True-        Just (DnK, faConc, c) -> do-            (j, (faPrem', faConc')) <- freshCoerceRuleNode-            insertEdges [ (c, faConc , faPrem', (j, PremIdx 0)) ]-            _ <- solveWith (j, ConcIdx 0) faConc'-            return True--        Nothing               -> return False----- | Solve unique actions. Returns 'True' iff the sequent was changed.-solveUniqueActions :: SeProof Bool-solveUniqueActions = do-    rules       <- nonSilentRules <$> askM pcRules-    actionAtoms <- gets sActionAtoms--    let uniqueActions = [ x | [x] <- group (sort allActions) ]-        allActions    = [ (tag, length ts) -                        | ru <- rules, Fact tag ts <- get rActs ru ]--        isUnique (Fact tag ts) = (tag, length ts) `elem` uniqueActions--        trySolve (i, fa)-          | isUnique fa = solveAction rules (i, fa) >> return True-          | otherwise   = return False--    or <$> mapM trySolve actionAtoms----- | Exploit that up-premises must always be deduced before the same--- down-premise.-exploitUniqueMsgOrder :: SeProof ()-exploitUniqueMsgOrder = do-    nodes     <- M.toList <$> getM sNodes-    dedBefore <- gets sDedBeforeAtoms-    let prems = M.fromList $ -            dedBefore <|> -- also incorporate deducible-before atoms.-            do (i, ru) <- nodes-               fa      <- get rPrems ru-               case kFactView fa of-                 Just (UpK, _, m) -> [ (m', i) | m' <- input m ]-                 _                -> mzero--        concs = M.fromList $ do-            (i, ru) <- nodes-            fa      <- get rConcs ru-            case kFactView fa of-              Just (DnK, _, m) -> return (m, i)-              _                -> mzero--        mkLess i j = Less (varTerm i) (varTerm j)--    -- we can add all elements where we have an intersection-    modM sAtoms $ flip S.union $ S.fromList-                $ M.elems $ M.intersectionWith mkLess concs prems---- | Exploit that instances of the 'Fresh' rule are unique.------ Returns 'True' if a change was done.-exploitFreshUnique :: SeProof Bool-exploitFreshUnique = do-    -- gather fresh rule nodes and merge nodes with identical conclusions-    updates <- gets ( map merge-                    . groupSortOn (get (rConc (ConcIdx 0)) . snd)-                    . filter (isFreshRule . snd)-                    . M.toList-                    . get sNodes-                    )-    -- check if there are changes to be applied-    if all (null . snd) updates-      then do return False-      else do modM sNodes (foldr (.) id $ map fst updates)-              solveNodeIdEqs $ concatMap snd updates-              return True-  where-    -- merge duplicate ones by removing all but one node and adding the-    -- equalities between the kept nodes and the removed nodes-    merge []            = error "exploitFreshUnique: impossible"-    merge (keep:remove) =-      ( \nodes -> foldl' (flip M.delete) nodes (map fst remove)-      , map (Equal (fst keep) . fst) remove-      )---- | Merge multiple incoming edges to all facts and multiple outgoing edges--- from linear facts.-exploitEdgeProps :: SeProof Bool -- True, if a simplification step happened.-exploitEdgeProps = do-    se <- gets id-    let edges = S.toList (get sEdges se)-    (||) <$> mergeNodes eSrc eTgt edges-         <*> mergeNodes eTgt eSrc (filter (proveLinearConc se . eSrc) edges)-  where-    -- merge the nodes on the 'mergeEnd' for edges that are equal on the-    -- 'compareEnd'-    mergeNodes mergeEnd compareEnd edges-      | null eqs  = return False-      | otherwise = do-            -- all indices of merged premises and conclusions must be equal-            contradictoryIf (not $ and [snd l == snd r | Equal l r <- eqs])-            -- nodes must be equal-            solveNodeIdEqs $ map (fmap fst) eqs-            return True-      where-        eqs = concatMap (merge mergeEnd) $ groupSortOn compareEnd edges--        merge _    []            = error "exploitEdgeProps: impossible"-        merge proj (keep:remove) = map (Equal (proj keep) . proj) remove----- | Merge nodes with equal non-pair msg conclusions.------ PRE: There must not be any node in the sequent with a 'KU' conclusion--- deriving a pair, inversion, or multiplication. This is in invariant of--- our constraint solver.-exploitUniqueMsgConcs :: SeProof Bool-exploitUniqueMsgConcs = do-    nodes <- M.toList <$> getM sNodes-    let (coerce, nonCoerce) = partitionEithers $ do-          node@(_, ru) <- nodes-          fa      <- get rConcs ru-          case kFactView fa of-            Nothing                          -> mzero-            Just (_, _, m) | isCoerceRule ru -> return $ Left  (m, node)-                           | otherwise       -> return $ Right (m, node)--        -- coerce nodes can only be merged with themselves.-        (removals1, eqs1) = analyze coerce-        -- all other nodes can be merged with each other.-        (removals2, eqs2) = analyze nonCoerce-        eqs               = eqs1 ++ eqs2--    -- check if there are any changes to be done-    if null eqs-        then return False-        else do-            modM sNodes (removals1 . removals2)-            solveNodeIdEqs          $ map (fmap fst) eqs-            solveRuleEqs   SplitNow $ map (fmap snd) eqs-            return True-  where-    analyze = (foldr (.) id *** concat) . unzip . map merge . groupSortOn fst--    merge []            = error "exploitUniqueMsgs: impossible"-    merge (keep:remove) =-      ( \nodes -> foldl' (flip M.delete) nodes (map (fst . snd) remove)-      , map (Equal (snd keep) . snd) remove-      )---- | Apply a list of changes to the proof state. Return True, if at least one--- change was applied; i.e., the list of changes is not null.-applyChanges :: [SeProof ()] -> SeProof Bool-applyChanges changes = sequence_ changes >> return (not $ null changes)---- | Are these two rule instances unifiable.-unifiableRuleACInsts :: MaudeHandle -> RuleACInst -> RuleACInst -> Bool-unifiableRuleACInsts maude ru1 ru2 = -    not $ null $ (`runReader` maude) $ unifyRuleACInstEqs [Equal ru1 ru2]---- | Simplify implications of the form @ (i < j) ==> F @: They are left-alone,--- if either @i@ or @j@ have not yet a node associated, converted to @j < i@,--- if the nodes of @j@ and @i@ are non-unifiable, and converted to the--- disjunction @i = j | j < i@, otherwise.------ True is returned if some change was performed.-simplifyNegativeOrderings :: SeProof Bool-simplifyNegativeOrderings = do-    fms   <- getM sFormulas-    nodes <- getM sNodes-    maude <- getMaudeHandle-    applyChanges $ do-        fm@(GGuarded All [] [Less i0 j0] gf) <- S.toList fms-        guard (gf == gfalse)-        case  unifiableRuleACInsts maude <$> M.lookup (nodeFromTerm i0) nodes-                                         <*> M.lookup (nodeFromTerm j0) nodes-         of-          Just b  -> return $ do-            modM sFormulas       $ S.delete fm-            modM sSolvedFormulas $ S.insert fm-            if b-              then modM sFormulas $ S.insert $ -                       gdisj $ [GAto (EqE i0 j0), GAto (Less j0 i0)]-              else modM sAtoms $ S.insert $ bvarToLVar $ Less j0 i0-          Nothing -> []-  where-    nodeFromTerm (viewTerm -> Lit (Var (Free v))) | lvarSort v == LSortNode = v-    nodeFromTerm t                                                          = error $-        "expected free node variable, but got '" ++ show t ++ "'"----- | Exploit that no node with a label can be after the last node. For--- non-unifiable nodes the ordering is introduced directly. For the--- remaining ones a disjunction is introduced.------ True is returned if some change was performed.-exploitLastNode :: SeProof Bool-exploitLastNode = do-    lasts <- gets sLastAtoms-    nodes <- getM sNodes-    case lasts of-      []      -> return False-      [iLast] -> -- single last node => add ordering constraints-         case M.lookup iLast nodes of-           Nothing     -> return False-           Just ruLast -> do-              beforeLast <- gets (D.reachableSet lasts . sRawGreaterRel)-              fms        <- getM sFormulas-              maude      <- getMaudeHandle-              applyChanges $ do-                  (i, ru) <- M.toList nodes-                  let disj = mkOrdDisj i iLast-                  guard $ (i /= iLast) &&-                           -- only consider nodes with action constraints-                          (not $ null $ get rActs ru)  && -                          (i `S.notMember` beforeLast) &&-                          (disj `S.notMember` fms)-                  if unifiableRuleACInsts maude ru ruLast-                    then return $ modM sFormulas $ S.insert disj-                    else return $ modM sAtoms $ S.insert $ -                             Less (varTerm i) (varTerm iLast)--      _ -> do -- multiple last nodes => merge them-              solveTermEqs SplitNow $ zipWith mkEq lasts (tail lasts)-              return True-  where-    mkEq i j        = Equal (varTerm i) (varTerm j)-    mkOrdDisj i0 j0 = gdisj $ [GAto (EqE i j), GAto (Less i j)]-      where-        i = lit $ Var $ Free i0-        j = lit $ Var $ Free j0---- | @setNodes nodes@ normalizes the @nodes@ such that node ids are unique and--- then updates the @sNodes@ field of the proof state to the corresponding map.--- Return @True@ iff new equalities have been added to the equation store.-setNodes :: [(NodeId, RuleACInst)] -> SeProof Bool-setNodes nodes0 = do-    sNodes =: M.fromList nodes-    if null ruleEqs then                         return False-                    else solveRuleEqs SplitLater ruleEqs >> return True-  where-    -- merge nodes with equal node id-    (ruleEqs, nodes) = first concat $ unzip $ map merge $ groupSortOn fst nodes0--    merge []            = error "setNodes: impossible"-    merge (keep:remove) = (map (Equal (snd keep) . snd) remove, keep)---- | Apply the current substitution of the equation store to the domain--- of the '_sNodes' field and restore the one-rule-per-node property. Returns--- @True@ if there were additional equalities added to the equation store.-substNodesDomain :: SeProof Bool-substNodesDomain =-    go False-  where-    go changed = do-        subst <- getM sSubst-        nodes <- gets (map (first (apply subst)) . M.toList . get sNodes)-        changed' <- setNodes nodes-        if changed' then go True-                    else return changed---- | Apply the current substitution of the equation store to the '_sNodes'--- field. Returns @True@ if there were additional equalities added to the--- equation store.-substNodes :: SeProof Bool-substNodes = do-    changed <- substNodesDomain-    (modM sNodes . M.map . apply) =<< getM sSubst-    return changed---- | Apply the current substitution of the equation store to the remainder of--- the sequent.-substSequent :: SeProof ()-substSequent = do-    _ <- substNodes-    substPart sEdges-    substPart sMsgEdges-    substPart sChains-    substPart sAtoms-    substPart sFormulas-    substPart sSolvedFormulas-    substPart sLemmas---- | Apply the current substitution of the equation store to a part of the--- sequent.-substPart :: Apply a => (Sequent :-> a) -> SeProof ()-substPart l = modM l =<< (apply <$> getM sSubst)---- | @conjoinSequent se@ conjoins the logical information in @se@ to the proof--- state. It assumes that the free variables in @se@ are shared with the free--- variables in the proof state.-conjoinSequent :: Sequent -> SeProof ()-conjoinSequent se = do-    kind <- getM sCaseDistKind -    unless (kind == get sCaseDistKind se) $-        error "conjoinSequent: typing-kind mismatch"-    joinSets sEdges-    joinSets sMsgEdges-    joinSets sChains-    joinSets sAtoms-    joinSets sFormulas-    joinSets sSolvedFormulas-    joinSets sLemmas-    -- update nodes-    _ <- (setNodes . (M.toList (get sNodes se) ++) . M.toList) =<< getM sNodes-    -- conjoin equation store-    modM sConjDisjEqs (`mappend` get sConjDisjEqs se)-    solveSubstEqs SplitNow $ get sSubst se-    -- propagate substitution changes-    substSequent-  where-    joinSets :: Ord a => (Sequent :-> S.Set a) -> SeProof ()-    joinSets proj = modM proj (`S.union` get proj se)----- Unification through the equation store of the embedded sequent---------------------------------------------------------------------- | @noContradictoryEqStore@ suceeds iff the equation store is not--- contradictory.-noContradictoryEqStore :: SeProof ()-noContradictoryEqStore =-    (contradictoryIf . eqsIsFalse) =<< getM sEqStore---- | Add a list of term equalities to the equation store. And---  split resulting disjunction of equations according---  to given split strategy.-solveTermEqs :: SplitStrategy -> [Equal LNTerm] -> SeProof ()-solveTermEqs splitStrat eqs = do-    hnd <- getMaudeHandle-    se <- gets id-    setM sEqStore =<< simp hnd (substCreatesNonNormalTerms hnd se)-                  =<< disjunctionOfList-                  =<< addEqs splitStrat hnd eqs-                  =<< getM sEqStore-    noContradictoryEqStore---- | Add a list of equalities in substitution form to the equation store-solveSubstEqs :: SplitStrategy -> LNSubst -> SeProof ()-solveSubstEqs split subst =-    solveTermEqs split [Equal (varTerm v) t | (v, t) <- substToList subst]---- | Add a list of node equalities to the equation store.-solveNodeIdEqs :: [Equal NodeId] -> SeProof ()-solveNodeIdEqs = solveTermEqs SplitNow . map (fmap varTerm)---- | Add a list of fact equalities to the equation store, if possible.-solveFactEqs :: SplitStrategy -> [Equal LNFact] -> SeProof ()-solveFactEqs split eqs = do-    contradictoryIf (not $ all evalEqual $ map (fmap factTag) eqs)-    solveListEqs (solveTermEqs split) $ map (fmap factTerms) eqs---- | Add a list of rule equalities to the equation store, if possible.-solveRuleEqs :: SplitStrategy -> [Equal RuleACInst] -> SeProof ()-solveRuleEqs split eqs = do-    contradictoryIf (not $ all evalEqual $ map (fmap (get rInfo)) eqs)-    solveListEqs (solveFactEqs split) $-        map (fmap (get rConcs)) eqs ++ map (fmap (get rPrems)) eqs---- | Solve a list of equalities using the given solver.-solveListEqs :: ([Equal a] -> SeProof b) -> [(Equal [a])] -> SeProof b-solveListEqs solver eqs = do-    contradictoryIf (not $ all evalEqual $ map (fmap length) eqs)-    solver $ concatMap flatten eqs-  where-    flatten (Equal l r) = zipWith Equal l r----- | Solve the constraints associated with a rule with the given vertex.-solveRuleConstraints :: Maybe RuleACConstrs -> SeProof ()-solveRuleConstraints (Just eqConstr) = do-    hnd <- getMaudeHandle-    setM sEqStore-        -- do not use expensive substCreatesNonNormalTerms here-        =<< (simp hnd (const False) . addRuleVariants eqConstr)-        =<< getM sEqStore-    noContradictoryEqStore-solveRuleConstraints Nothing = return ()----------------------------------------------------------------------------------- Extracting and solving goals---------------------------------------------------------------------------------data Usefulness = Useful | Useless-  deriving (Show, Eq, Ord)---- FIXME: SM: Remove support for requires facts.--- | All open premises stemming both from labelled nodes and requires facts.-openPremiseGoals :: Sequent -> [(Usefulness, Goal)]-openPremiseGoals se = do-    (i, ru) <- oneOfMap $ get sNodes se-    (u, fa) <- enumPrems ru-    let p = (i, u)-        breakers = ruleInfo (get praciLoopBreakers) (const []) $ get rInfo ru-    case fa of-      -- up-K facts-      (kFactView -> Just (UpK, _, m))  -> case input m of-          [m'] | m == m' -> do-            guard (not (trivial m') && (p, m') `S.notMember` coveredMsgPrems)-            return $ markUseless m' i $ PremiseG p fa True-          m's            -> do-            m' <- sortednub m's-            guard (not (trivial m') && (p, m') `S.notMember` coveredMsgPrems)-            return $ markUseless m' i $ PremUpKG p m'--      -- down-K facts-      (kFactView -> Just (DnK, _, _))-        | p `S.member` coveredPrems -> mzero-        | otherwise                 -> return . (Useful,)  $ PremDnKG p-      -- all other facts-      _ | p `S.member` coveredPrems -> mzero-        | u `elem` breakers         -> return . (Useless,) $ PremiseG p fa True-        | otherwise                 -> return . (Useful,) $  PremiseG p fa False-  where-    coveredPrems     = S.fromList $ eTgt <$> S.toList (get sEdges se) <|>-                                    cTgt <$> S.toList (get sChains se)--    coveredMsgPrems  = S.fromList $ do-        (c, p) <- [ (c, p) | MsgEdge c p <- S.toList (get sMsgEdges se) ] <|>-                  [ (c, p) | Edge c p    <- S.toList (get sEdges se)    ]--        case kFactView =<< resolveNodeConcFact c se of-          Just (UpK, _, m) -> return (p, m)-          _                -> []--    existingDeps = sRawLessRel se--    -- We use the following heuristic for marking KU-goals as useful (worth-    -- solving now) or useless (to be delayed until no more useful goals-    -- remain). We ignore all goals that do not contain a fresh variable-    -- or where there exists a node, not after the premise or the last node,-    -- providing an Out or KD conclusion that provides the message we are-    -- looking for as a toplevel term.-    ---    -- If such a node exist, then solving the goal will result in at least one-    -- case where we didn't make real progress except.-    markUseless m i-        | not (containsFreshVars m) || deducible = (,) Useless-        | otherwise                              = (,) Useful-        where-          containsFreshVars = any ((LSortFresh ==) . lvarSort) . frees--          toplevelTerms t@(destPair -> Just (t1, t2)) = -              t : toplevelTerms t1 ++ toplevelTerms t2-          toplevelTerms t@(destInverse -> Just t1) = t : toplevelTerms t1-          toplevelTerms t = [t]--          deducible = or $ do-              (j, ru) <- M.toList $ get sNodes se-              -- We cannot deduce a message from a last node.-              guard (Last (varTerm j) `S.notMember` get sAtoms se)-              let derivedMsgs = concatMap toplevelTerms $-                      [ t | Fact OutFact [t] <- get rConcs ru] <|>-                      [ t | Just (DnK, _, t) <- kFactView <$> get rConcs ru]-              -- m is deducible from j without an immediate contradiction-              -- if it is a derived message of 'ru' and the dependency does-              -- not make the graph cyclic.-              return $ m `elem` derivedMsgs && -                       not (D.cyclic ((j, i) : existingDeps))----- | All open chain goals. These are all the chains that do not end in a--- message variable in the sequent because they are deleted upon solving.-openChainGoals :: Sequent -> [Goal]-openChainGoals se = do-    ch@(Chain c _) <- S.toList $ get sChains se-    case kFactView (nodeConcFact c se) of-      Just (DnK, _, m) | isMsgVar m -> mzero-                       | otherwise  -> return $ ChainG ch-      fa -> error $ "openChainGoals: impossible fact: " ++ show fa---- | All open splitting goals.-openSplitGoals :: Sequent -> [Goal]-openSplitGoals se = SplitG <$> eqSplits (get sEqStore se)---- | All open action goals.------ FIXME: Only `Ded` goals that are guaranteed to be a non-pair,--- non-inversion, and non-product are considered open. This is wrong with--- respect to our definition of a solved form of the constraint system.-openActionGoals :: Sequent -> [Goal]-openActionGoals se = do-    (i, fa) <- sActionAtoms se-    case dedFactView fa of-        Just m | isPair m || isMsgVar m || isProduct m || isInverse m -> mzero-        _ -> return $ ActionG i fa---- | All open goals (non-deterministic choices of possible proof steps) in the--- sequent.-openGoals :: Sequent -> [Goal]-openGoals se = delayUseless $ sortDecisionTree solveFirst $ concat $-   [ (Useful,) <$> openActionGoals se-   , (Useful,) <$> openDisjunctionGoals se-   , (Useful,) <$> openChainGoals se-   , openPremiseGoals se-   -- SM: Commented out as automatic saturation works again.-   -- , (Useful,) <$> openImplicationGoals se-   , (Useful,) <$> openSplitGoals se-   ]-  where-    solveFirst = map (. snd)-        [ isDisjGoal, isProtoFactGoal-        , isActionGoal-        , isChainGoal, isFreshKnowsGoal-        , isSplitGoalSmall, isDoubleExpGoal ]--    isProtoFactGoal (PremiseG _ (Fact KUFact _) _) = False-    isProtoFactGoal (PremiseG _ _               _) = True-    isProtoFactGoal _                              = False--    msgPremise (PremiseG _ (Fact KUFact [_, m]) _) = Just m-    msgPremise (PremUpKG _ m)                      = Just m-    msgPremise _                                   = Nothing--    isFreshKnowsGoal goal = case msgPremise goal of-        Just (viewTerm -> Lit (Var lv)) | lvarSort lv == LSortFresh -> True-        _                                                           -> False--    isDoubleExpGoal goal = case msgPremise goal of-        Just (viewTerm2 -> FExp  _ (viewTerm2 -> FMult _)) -> True-        _                                                  -> False--    isSplitGoalSmall (SplitG sid) = splitCasenum (get sEqStore se) sid < 3-    isSplitGoalSmall _            = False--    delayUseless = map snd . sortOn fst----- | @sortDecisionTree xs ps@ returns a reordering of @xs@--- such that the sublist satisfying @ps!!0@ occurs first,--- then the sublist satisfying @ps!!1@, and so on.-sortDecisionTree :: [a -> Bool] -> [a] -> [a]-sortDecisionTree []     xs = xs-sortDecisionTree (p:ps) xs = sat ++ sortDecisionTree ps nonsat-  where (sat, nonsat) = partition p xs---- | Solve an action goal.------ PRE: If the action is a 'Ded' fact, then its argument must not be--- instantiatable to a pair, inversion, or a product.----solveAction :: [RuleAC]       -- ^ All rules labelled with an action-            -> (LVar, LNFact) -- ^ The action we are looking for.-            -> SeProof String -- ^ Sensible case name.-solveAction rules (i, fa) = do-    modM sAtoms (S.delete (Action (varTerm i) fa))-    mayRu <- M.lookup i <$> getM sNodes-    showRuleCaseName <$> case mayRu of-        Nothing -> do -- case dedFactView fa of-            -- Just m  -> do -- 'Ded' facts are dealt with specially.-                -- solvePremUpK -            -- Nothing -> do -                ru  <- ruleNode i rules-                act <- disjunctionOfList $ get rActs ru-                solveFactEqs SplitNow [Equal fa act]-                return ru--        Just ru -> do unless (fa `elem` get rActs ru) $ do-                        act <- disjunctionOfList $ get rActs ru-                        solveFactEqs SplitNow [Equal fa act]-                      return ru---- | Solve a K-up-knowledge premise.-solvePremUpK :: [RuleAC]  -- ^ All construction rules.-             -> NodePrem-             -> LNTerm-             -> SeProof String-solvePremUpK rules p m = do-    (ru, c, faConc) <- freshRuleConc rules-    case kFactView faConc of-      Just (UpK, _, m') ->-        do solveTermEqs SplitNow [(Equal m m')]-           modM sMsgEdges (S.insert (MsgEdge c p))-           return $ showRuleCaseName ru--      _ -> error $ "solvePremUpK: unexpected fact: " ++ show faConc---- | Solve a premise with a direct edge from a unifying conclusion.------ Note that 'In' and 'Fr' facts are solved directly when adding a 'ruleNode'.-solvePremise :: [RuleAC]       -- ^ All construction and protocol rules.-             -> NodePrem       -- ^ Premise to solve.-             -> LNFact         -- ^ Fact required at this premise.-             -> SeProof String -- ^ Case name to use-solvePremise rules p faPrem = do-    (ru, c, faConc) <- freshRuleConc rules-    solveFactEqs SplitNow [(Equal faPrem faConc)]-    modM sEdges (S.insert (Edge c p))-    return $ showRuleCaseName ru---- | Solve a K-down-knowledge premise.-solvePremDnK :: [RuleAC] -- ^ All rules that derive a send fact.-             -> NodePrem -- ^ The K-down premise to solve.-             -> SeProof String-solvePremDnK rules p = do-    iLearn    <- freshLVar "vl" LSortNode-    mLearn    <- varTerm <$> freshLVar "t" LSortMsg-    concLearn <- kdFact (Just CanExp) mLearn-    let premLearn = outFact mLearn-        ruLearn = Rule (IntrInfo IRecvRule) [premLearn] [concLearn] []-        cLearn = (iLearn, ConcIdx 0)-        pLearn = (iLearn, PremIdx 0)-    modM sNodes  (M.insert iLearn ruLearn)-    modM sChains (S.insert (Chain cLearn p))-    solvePremise rules pLearn premLearn---- | Solve a chain constraint.-solveChain :: [RuleAC]        -- ^ All destruction rules.-           -> Chain           -- ^ The chain to extend by one step-           -> SeProof String-solveChain rules ch@(Chain c p) = do-    modM sChains (S.delete ch)-    faConc  <- gets $ nodeConcFact c-    (do -- solve it by a direct edge-        faPrem <- gets $ nodePremFact p-        solveFactEqs SplitNow [(Equal faPrem faConc)]-        modM sEdges  (S.insert (Edge c p))-        let m = case kFactView faConc of-                  Just (DnK, _, m') -> m'-                  _                 -> error $ "solveChain: impossible"-            caseName (viewTerm -> FApp o _) = show o-            caseName t                      = show t-        return $ caseName m -     `disjunction`-     do -- extend it with one step-        (i, ru)     <- freshRuleNode rules-        (v, faPrem) <- disjunctionOfList $ enumPrems ru-        solveFactEqs SplitNow [(Equal faPrem faConc)]-        modM sEdges (S.insert (Edge c (i, v)))-        modM sChains (S.insert (Chain (i, ConcIdx 0) p))-        return $ showRuleCaseName ru-     )---- | Solve an equation split.-solveSplit :: SplitId -> SeProof String-solveSplit x = do-    split <- gets ((`splitAtPos` x) . get sEqStore)-    let errMsg = error "solveSplit: split of equations on unconstrained variable!"-    store  <- maybe errMsg disjunctionOfList split-    hnd    <- getMaudeHandle-    se <- gets id-    store' <- simp hnd (substCreatesNonNormalTerms hnd se) store-    contradictoryIf (eqsIsFalse store')-    sEqStore =: store'-    return "split"---- | Solve a disjunction of guarded formulas using splitting.--- Returns a case name.-solveDisjunction :: Disj LNGuarded -> SeProof String-solveDisjunction disj = do-    modM sSolvedFormulas (S.insert $ GDisj disj)-    modM sSolvedFormulas (S.insert $ GDisj disj)-    (i, gfm) <- disjunctionOfList $ zip [(1::Int)..] $ getDisj disj-    modM sFormulas (S.insert gfm)-    return $ "case_" ++ show i---- | @solveGoal rules goal@ enumerates all possible solutions how this goal--- could be solved in the context of the given @rules@.------ Returns a usable case name.----solveGoal :: Goal -> SeProof String-solveGoal goal = do-    rules <- askM pcRules-    trace ("   solving goal: " ++ render (prettyGoal goal)) $-      case goal of-        ActionG i fa   -> solveAction  (nonSilentRules rules) (i, fa) -        PremiseG p fa _mayLoop -> -            solvePremise (get crProtocol rules ++ get crConstruct rules) p fa-        PremDnKG p     -> solvePremDnK (get crProtocol  rules) p-        PremUpKG p m   -> solvePremUpK (get crConstruct rules) p m-        ChainG ch      -> solveChain   (get crDestruct  rules) ch-        SplitG i       -> solveSplit i-        DisjG disj     -> solveDisjunction disj-        ImplG gf       -> modM sFormulas (S.insert gf) >> return "add_formula"-
− src/Theory/Proof/Sequent/Dot.hs 
@@ -1,487 +0,0 @@-{-# LANGUAGE TemplateHaskell, ViewPatterns, TypeOperators #-}--- |--- Copyright   : (c) 2010, 2011 Simon Meier--- License     : GPL v3 (see LICENSE)--- --- Maintainer  : Simon Meier <iridcode@gmail.com>--- Portability : GHC only------ Conversion of the graph part of a sequent to a Graphviz Dot file.-module Theory.Proof.Sequent.Dot (-    dotSequentLoose-  , dotSequentCompact-  , compressSequent-  , BoringNodeStyle(..)-  ) where--import Safe-import Data.Maybe-import Data.Char (isSpace)-import Data.List-import Data.Monoid (Any(..))-import qualified Data.Set        as S-import qualified Data.Map        as M-import qualified Data.DAG.Simple as D-import Data.Color--import Extension.Prelude-import Extension.Data.Label--import Control.Basics-import Control.Monad.State (StateT, evalStateT)-import Control.Monad.Reader--import qualified Text.Dot as D-import Text.PrettyPrint.Class--import Theory.Rule-import Theory.Proof.Sequent--type NodeColorMap = M.Map (RuleInfo ProtoRuleACInstInfo IntrRuleACInfo) (HSV Double)-type SeDot = ReaderT (Sequent, NodeColorMap) (StateT DotState D.Dot)---- | State to avoid multiple drawing of the same entity.-data DotState = DotState {-    _dsNodes   :: M.Map NodeId   D.NodeId-  , _dsPrems   :: M.Map NodePrem D.NodeId-  , _dsConcs   :: M.Map NodeConc D.NodeId-  , _dsSingles :: M.Map (NodeConc, NodePrem) D.NodeId-  }--$(mkLabels [''DotState])---- | Lift a 'D.Dot' action.-liftDot :: D.Dot a -> SeDot a-liftDot = lift . lift---- | All edges in a bipartite graph that have neither start point nor endpoint--- in common with any other edge.-singleEdges :: (Ord a, Ord b) => [(a,b)] -> [(a,b)]-singleEdges es = -    singles fst es `intersect` singles snd es-  where-    singles proj = concatMap single . groupOn proj . sortOn proj-    single []  = error "impossible"-    single [x] = return x-    single _   = mzero---- | Get a lighter color.-lighter :: HSV Double -> RGB Double-lighter = hsvToRGB -- fmap (\c -> 1 - 0.3*(1-c)) . hsvToRGB---- | Ensure that a 'SeDot' action is only executed once by querying and--- updating the 'DotState' accordingly.-dotOnce :: Ord k -        => (DotState :-> M.Map k D.NodeId) -- ^ Accessor to map storing this type of actions.-        -> k                               -- ^ Action index.-        -> SeDot D.NodeId                  -- ^ Action to execute only once.-        -> SeDot D.NodeId                          -dotOnce mapL k dot = do-    i <- join $ (maybe dot return . M.lookup k) `liftM` getM mapL-    modM mapL (M.insert k i)-    return i--dotNode :: NodeId -> SeDot D.NodeId-dotNode v = dotOnce dsNodes v $ do-    (se, colorMap) <- ask-    let nodes = get sNodes se-        dot info moreStyle facts = do-            vId <- liftDot $ D.node $ [("label", show v ++ info),("shape","ellipse")] -                                      ++ moreStyle-            _ <- facts vId-            return vId--    case M.lookup v nodes of-      Nothing -> do-          dot "" [] (const $ return ()) -- \vId -> do-              {--              premIds <- mapM dotPrem-                           [ NodePremFact v fa -                           | SeRequires v' fa <- S.toList $ get sRequires se-                           , v == v' ]-              sequence_ [ dotIntraRuleEdge premId vId | premId <- premIds ]-              -}-      Just ru -> do-          let -              color     = M.lookup (get rInfo ru) colorMap-              nodeColor = maybe "white" (rgbToHex . lighter) color-          dot (label ru) [("fillcolor", nodeColor),("style","filled")] $ \vId -> do-              premIds <- mapM dotPrem-                           [ (v,i) | (i,_) <- enumPrems ru ]-              concIds <- mapM dotConc -                           [ (v,i) | (i,_) <- enumConcs ru ]-              sequence_ [ dotIntraRuleEdge premId vId | premId <- premIds ]-              sequence_ [ dotIntraRuleEdge vId concId | concId <- concIds ]-  where-    label ru = " : " ++ render nameAndActs-      where-        nameAndActs = -            ruleInfo (prettyProtoRuleName . get praciName) prettyIntrRuleACInfo (get rInfo ru) <->-            brackets (vcat $ punctuate comma $ map prettyLNFact $ get rActs ru)---- | An edge from a rule node to its premises or conclusions.-dotIntraRuleEdge :: D.NodeId -> D.NodeId -> SeDot ()-dotIntraRuleEdge from to = liftDot $ D.edge from to [("color","gray")]--{---- | An edge from a rule node to some of its premises or conclusions.-dotNonFixedIntraRuleEdge :: D.NodeId -> D.NodeId -> SeDot ()-dotNonFixedIntraRuleEdge from to = -    liftDot $ D.edge from to [("color","steelblue")]--}---- | The style of a node displaying a fact.-factNodeStyle :: LNFact -> [(String,String)]-factNodeStyle fa-  | isJust (kFactView fa) = []-  | otherwise             = [("fillcolor","gray85"),("style","filled")]---- | An edge that shares no endpoints with another edge and is therefore--- contracted.------ FIXME: There may be too many edges being contracted.-dotSingleEdge :: (NodeConc, NodePrem) -> SeDot D.NodeId-dotSingleEdge edge@(_, to) = dotOnce dsSingles edge $ do-    se <- asks fst-    let fa    = nodePremFact to se-        label = render $ prettyLNFact fa-    liftDot $ D.node $ [("label", label),("shape", "hexagon")]-                       ++ factNodeStyle fa---- | A compressed edge.-dotTrySingleEdge :: Eq c-                 => ((NodeConc, NodePrem) -> c) -> c-                 -> SeDot D.NodeId -> SeDot D.NodeId-dotTrySingleEdge sel x dot = do-    singles <- getM dsSingles-    maybe dot (return . snd) $ find ((x ==) . sel . fst) $ M.toList singles---- | Premises.-dotPrem :: NodePrem -> SeDot D.NodeId-dotPrem prem@(v, i) = -    dotOnce dsPrems prem $ dotTrySingleEdge snd prem $ do-        nodes <- asks (get sNodes . fst)-        let ppPrem = show prem -- FIXME: Use better pretty printing here-            (label, moreStyle) = fromMaybe (ppPrem, []) $ do-                ru <- M.lookup v nodes-                fa <- lookupPrem i ru-                return ( render $ prettyLNFact fa-                       , factNodeStyle fa-                       )-        liftDot $ D.node $ [("label", label),("shape",shape)] -                           ++ moreStyle-  where-    shape = "invtrapezium"---- | Conclusions.-dotConc :: NodeConc -> SeDot D.NodeId-dotConc = -    dotNodeWithIndex dsConcs fst rConcs (id *** getConcIdx) "trapezium"    -  where-    dotNodeWithIndex stateSel edgeSel ruleSel unwrap shape x0 = -        dotOnce stateSel x0 $ dotTrySingleEdge edgeSel x0 $ do-            let x = unwrap x0-            nodes <- asks (get sNodes . fst)-            let (label, moreStyle) = fromMaybe (show x, []) $ do-                    ru <- M.lookup (fst x) nodes-                    fa <- (`atMay` snd x) $ get ruleSel ru-                    return ( render $ prettyLNFact fa-                           , factNodeStyle fa-                           )-            liftDot $ D.node $ [("label", label),("shape",shape)] -                               ++ moreStyle---- | Convert the sequent to a 'D.Dot' action representing this sequent as a--- graph in the GraphViz format. The style is loose in the sense that each--- premise and conclusion gets its own node.-dotSequentLoose :: Sequent -> D.Dot ()-dotSequentLoose se =-    (`evalStateT` DotState M.empty M.empty M.empty M.empty) $ -    (`runReaderT` (se, nodeColorMap (M.elems $ get sNodes se))) $ do-        liftDot $ setDefaultAttributes-        -- draw single edges with matching facts.-        mapM_ dotSingleEdge $ singleEdges $ do-            Edge from to <- S.toList $ get sEdges se-            -- FIXME: ensure that conclusion and premise are equal-            guard (nodeConcFact from se == nodePremFact to se)-            return (from, to)-        sequence_ $ do-            (v, ru) <- M.toList $ get sNodes se-            (i, _)  <- enumConcs ru-            return (dotConc (v, i))-        sequence_ $ do-            (v, ru) <- M.toList $ get sNodes se-            (i, _)  <- enumPrems ru-            return (dotPrem (v,i))-        mapM_ dotNode     $ M.keys   $ get sNodes    se-        mapM_ dotEdge     $ S.toList $ get sEdges    se-        mapM_ dotChain    $ S.toList $ get sChains   se-        mapM_ dotMsgEdge  $ S.toList $ get sMsgEdges se-        mapM_ dotLess     $            sLessAtoms    se-  where-    dotEdge  (Edge src tgt)  = do-        mayNid <- M.lookup (src,tgt) `liftM` getM dsSingles-        maybe (dotGenEdge [] src tgt) (const $ return ()) mayNid--    dotChain (Chain src tgt) = -        dotGenEdge [("style","dashed"),("color","green")] src tgt --    dotMsgEdge (MsgEdge src tgt) = -        dotGenEdge [("style","dotted"),("color","orange")] src tgt --    dotLess (src, tgt) = do-        srcId <- dotNode src-        tgtId <- dotNode tgt-        liftDot $ D.edge srcId tgtId -            [("color","black"),("style","dotted"),("constraint","false")]-            -- setting constraint to false ignores less-edges when ranking nodes.--    dotGenEdge style src tgt = do-        srcId <- dotConc src-        tgtId <- dotPrem tgt-        liftDot $ D.edge srcId tgtId style--    {--    dotProvides (SeProvides v fa) = do-        vId <- dotNode v-        faId <- liftDot $ D.node [("label",label),("shape","trapezium")]-        dotNonFixedIntraRuleEdge vId faId-      where-        label = render $ prettyLNFact fa--    dotRequires (SeRequires v _fa) = do-       _vId <- dotNode v-       return ()-       -- FIXME: Reenable-       -- premId <- dotPrem (NodePremFact v fa)-       -- dotNonFixedIntraRuleEdge premId vId-    -}---- | Set default attributes for nodes and edges.-setDefaultAttributes :: D.Dot ()-setDefaultAttributes = do-  D.attribute ("nodesep","0.3")-  D.attribute ("ranksep","0.3")-  D.nodeAttributes [("fontsize","8"),("fontname","Helvetica"),("width","0.3"),("height","0.2")]-  D.edgeAttributes [("fontsize","8"),("fontname","Helvetica")]----- | Compute a color map for nodes labelled with a proof rule info of one of--- the given rules.-nodeColorMap :: [RuleACInst] -> NodeColorMap-nodeColorMap rules = -    M.fromList $ -      [ (get rInfo ru, getColor (gIdx, mIdx))-      | (gIdx, grp) <- groups, (mIdx, ru) <- zip [0..] grp ]-  where-    groupIdx ru | isDestrRule ru                   = 0-                | isConstrRule ru                  = 2-                | isFreshRule ru || isISendRule ru = 3-                | otherwise                        = 1--    -- groups of rules labeled with their index in the group-    groups = [ (gIdx, [ ru | ru <- rules, gIdx == groupIdx ru])-             | gIdx <- [0..3]-             ]-    -    -- color for each member of a group-    colors = M.fromList $ lightColorGroups intruderHue (map (length . snd) groups)-    getColor idx = fromMaybe (HSV 0 1 1) $ M.lookup idx colors--    -- The hue of the intruder rules-    intruderHue :: Double-    intruderHue = 18 / 360----------------------------------------------------------------------------------- Record based dotting----------------------------------------------------------------------------------- | The style for nodes of the intruder.-data BoringNodeStyle = FullBoringNodes | CompactBoringNodes-    deriving( Eq, Ord, Show )----- | Dot a node in record based (compact) format.-dotNodeCompact :: BoringNodeStyle -> NodeId -> SeDot D.NodeId-dotNodeCompact boringStyle v = dotOnce dsNodes v $ do-    (se, colorMap) <- ask-    let hasOutgoingEdge = -             or [ v == v' | Edge (v', _) _    <- S.toList $ get sEdges se ]-          || or [ v == v' | MsgEdge (v', _) _ <- S.toList $ get sMsgEdges se ]-    case M.lookup v $ get sNodes se of-      Nothing -> mkSimpleNode (show v) []-      Just ru -> do-          let color     = M.lookup (get rInfo ru) colorMap-              nodeColor = maybe "white" (rgbToHex . lighter) color-              attrs     = [("fillcolor", nodeColor),("style","filled")]-          ids <- mkNode ru attrs hasOutgoingEdge-          let prems = [ ((v, i), nid) | (Just (Left i),  nid) <- ids ]-              concs = [ ((v, i), nid) | (Just (Right i), nid) <- ids ]-          modM dsPrems $ M.union $ M.fromList prems-          modM dsConcs $ M.union $ M.fromList concs-          return $ fromJust $ lookup Nothing ids-  where--    mkSimpleNode lbl attrs = -        liftDot $ D.node $ [("label", lbl),("shape","ellipse")] ++ attrs--    mkNode ru attrs hasOutgoingEdge-      -- single node, share node-id for all premises and conclusions-      | boringStyle == CompactBoringNodes && -        (isIntruderRule ru || isFreshRule ru) = do-            let lbl | hasOutgoingEdge = show v ++ " : " ++ showRuleCaseName ru-                    | otherwise       = concatMap snd as-            nid <- mkSimpleNode lbl []-            return [ (key, nid) | (key, _) <- ps ++ as ++ cs ]-      -- full record syntax-      | otherwise =-            fmap snd $ liftDot $ (`D.record` attrs) $-            D.vcat $ map D.hcat $ map (map (uncurry D.portField)) $ -            filter (not . null) [ps, as, cs]-      where-        ps = renderRow [ (Just (Left i),  prettyLNFact p) | (i, p) <- enumPrems ru ]-        as = renderRow [ (Nothing,        ruleLabel ) ]-        cs = renderRow [ (Just (Right i), prettyLNFact c) | (i, c) <- enumConcs ru ]--        ruleLabel =-            prettyNodeId v <-> colon <-> text (showRuleCaseName ru) <>-            (brackets $ vcat $ punctuate comma $ map prettyLNFact $ get rActs ru)--        renderRow annDocs =-          zipWith (\(ann, _) lbl -> (ann, lbl)) annDocs $ -            -- magic factor 1.3 compensates for space gained due to-            -- non-propertional font-            renderBalanced 100 (max 30 . round . (* 1.3)) (map snd annDocs)--        renderBalanced :: Double           -- ^ Total available width-                       -> (Double -> Int)  -- ^ Convert available space to actual line-width.-                       -> [Doc]            -- ^ Initial documents-                       -> [String]         -- ^ Rendered documents-        renderBalanced _          _    []   = []-        renderBalanced totalWidth conv docs =-            zipWith (\w d -> widthRender (conv (ratio * w)) d) usedWidths docs-          where-            oneLineRender  = renderStyle (defaultStyle { mode = OneLineMode })-            widthRender w  = scaleIndent . renderStyle (defaultStyle { lineLength = w })-            usedWidths     = map (fromIntegral . length . oneLineRender) docs-            ratio          = totalWidth / sum usedWidths -            scaleIndent line = case span isSpace line of-              (spaces, rest) -> -                  -- spaces are not wide-enough by default => scale them up-                  let n = (1.5::Double) * fromIntegral (length spaces)-                  in  replicate (round n) ' ' ++ rest------ | Dot a sequent in compact form (one record per rule)-dotSequentCompact :: BoringNodeStyle -> Sequent -> D.Dot ()-dotSequentCompact boringStyle se = -    (`evalStateT` DotState M.empty M.empty M.empty M.empty) $ -    (`runReaderT` (se, nodeColorMap (M.elems $ get sNodes se))) $ do-        liftDot $ setDefaultAttributes-        mapM_ (dotNodeCompact boringStyle) $ M.keys   $ get sNodes    se-        mapM_ dotEdge                    $ S.toList $ get sEdges    se-        mapM_ dotChain                   $ S.toList $ get sChains   se-        mapM_ dotMsgEdge                 $ S.toList $ get sMsgEdges se-        mapM_ dotLess                    $            sLessAtoms    se-  where-    missingNode shape label = liftDot $ D.node $ [("label", render label),("shape",shape)] -    dotPremC prem = dotOnce dsPrems prem $ missingNode "invtrapezium" $ prettyNodePrem prem-    dotConcC conc = dotOnce dsConcs conc $ missingNode "trapezium" $ prettyNodeConc conc-    dotEdge (Edge src tgt)  = do-        let check p = maybe False p (resolveNodePremFact tgt se) ||-                      maybe False p (resolveNodeConcFact src se)-            attrs | check isProtoFact = -                      [("style","bold"),("weight","10.0")] ++-                      (guard (check isPersistentFact) >> [("color","gray50")])-                  | check isKFact     = [("color","orangered2")]-                  | otherwise         = [("color","gray30")]-        dotGenEdge attrs src tgt--    dotGenEdge style src tgt = do-        srcId <- dotConcC src-        tgtId <- dotPremC tgt-        liftDot $ D.edge srcId tgtId style--    dotChain (Chain src tgt) = -        dotGenEdge [("style","dashed"),("color","green")] src tgt --    dotMsgEdge (MsgEdge src tgt) = -        dotGenEdge [("style","dotted"),("color","orange")] src tgt --    dotLess (src, tgt) = do-        srcId <- dotNodeCompact boringStyle src-        tgtId <- dotNodeCompact boringStyle tgt-        liftDot $ D.edge srcId tgtId -            [("color","black"),("style","dotted"),("constraint","false")]-            -- setting constraint to false ignores less-edges when ranking nodes.------------------------------------------------------------------------------------ Compressed versions of a sequent----------------------------------------------------------------------------------- | Drop 'Less' atoms entailed by the edges of the 'Sequent'.-dropEntailedOrdConstraints :: Sequent -> Sequent-dropEntailedOrdConstraints se =-    modify sAtoms (S.filter (not . entailed)) se-  where-    edges = sRawEdgeRel se--    entailed (Less (viewTerm -> Lit (Var from)) (viewTerm -> Lit (Var to))) =-       to `S.member` D.reachableSet [from] edges-    entailed _ = False---- | Unsound compression of the sequent that drops fully connected learns and--- knows nodes.-compressSequent :: Sequent -> Sequent-compressSequent se0 = -    foldl' (flip hideTransferNode) se $ -    [ x | x@(_, ru) <- M.toList $ get sNodes se-        , isFreshRule ru || isIntruderRule ru ]-  where-    se = dropEntailedOrdConstraints se0---- | @hideTransferNode v se@ hides node @v@ in sequent @se@ if it is a--- transfer node; i.e., a node annotated with a rule that is one of the--- special intruder rules or a rule with with at most one premise and --- at most one conclusion and both premises and conclusions have incoming--- respectively outgoing edges.------ The compression is chosen such that unly uninteresting nodes are that have--- no open goal are suppressed.-hideTransferNode :: (NodeId, RuleACInst) -> Sequent -> Sequent-hideTransferNode (v, ru) se = fromMaybe se $ do-    guard $    -         eligibleRule-      && (length eIns  == length (get rPrems ru))-      && (length eOuts == length (get rConcs ru))-      && all (\(Edge cIn pOut) -> nodeConcNode cIn /= nodePremNode pOut) eNews-      && notOccursIn sMsgEdges-      && notOccursIn sChains -      && notOccursIn sAtoms-      && notOccursIn sFormulas--    return $ modify sEdges (  (`S.union` S.fromList eNews)-                            . (`S.difference` S.fromList eIns)-                            . (`S.difference` S.fromList eOuts)-                           )-           $ modify sNodes (M.delete v)-           $ se-  where-    eligibleRule =-      any ($ ru) [isISendRule, isIRecvRule, isCoerceRule, isFreshRule] || -      ( null (get rActs ru) && -        all (\l -> length (get l ru) <= 1) [rPrems, rConcs]-      )--    selectPart :: (Sequent :-> S.Set a) -> (a -> Bool) -> [a]-    selectPart l p = filter p $ S.toList $ get l se--    notOccursIn :: HasFrees a => (Sequent :-> a) -> Bool-    notOccursIn l = not $ getAny $ foldFrees (Any . (v ==)) $ get l se--    eIns  = selectPart sEdges ((v ==) . nodePremNode . eTgt)-    eOuts = selectPart sEdges ((v ==) . nodeConcNode . eSrc)--    eNews = [ Edge cIn pOut | Edge cIn _ <- eIns, Edge _ pOut <- eOuts ]
− src/Theory/Proof/SolveGuarded.hs 
@@ -1,326 +0,0 @@-{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, TemplateHaskell #-}-{-# LANGUAGE StandaloneDeriving, TypeSynonymInstances, ViewPatterns #-}-{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}-  -- spurious warnings for view patterns--- |--- Copyright   : (c) 2011, 2012 Benedikt Schmidt & Simon Meier--- License     : GPL v3 (see LICENSE)--- --- Maintainer  : Benedikt Schmidt <beschmi@gmail.com>--- Portability : GHC only------ Ensuring consistency of a constraint system (sequent) with guarded trace--- formulas.-module Theory.Proof.SolveGuarded (-    saturateGuarded-  , openDisjunctionGoals-  , openImplicationGoals--  -- * Literal formula constants-  , gfalse-  ) where--import           Theory.Proof.Guarded-import           Theory.Atom-import           Term.LTerm--import           Theory.Proof.Types--import           Data.Typeable-import           Data.Data-import           Data.Maybe (catMaybes)-import qualified Data.Set as S--import           Control.Basics-import           Control.Monad.State hiding (get)-import           Control.Monad.Fresh-import           Control.Monad.Reader--import           Extension.Data.Label---- Terms, facts, and formulas with skolem constants-------------------------------------------------------- | A constant type that supports names and skolem constants.-data SkConst = SkName  Name-             | SkConst LVar-             deriving( Eq, Ord, Show, Data, Typeable )--type SkTerm    = VTerm SkConst LVar-type SkFact    = Fact SkTerm-type SkSubst   = Subst SkConst LVar-type SkGuarded = LGuarded SkConst---- | A term with skolem constants and bound variables-type BSkTerm   = VTerm SkConst BLVar---- | An term with skolem constants and bound variables-type BSkAtom   = Atom BSkTerm--instance IsConst SkConst---- | @saturateGuarded seq@ returns @Nothing@ if @sFormulas seq@ is already--- saturated and saturated it otherwise. Additionally, the equalities in the--- saturation are removed and returned separately. @sSolvedFormulas seq@ is--- used to determine which formulas are considered 'solved'.-saturateGuarded :: MonadFresh m-                => MaudeHandle-                -> Sequent-                -> m (Maybe ([Equal LNTerm], Sequent))-                   -- ^ return the new solved, unsolved, and equalities sets-saturateGuarded hnd se0 = do-    (eqs, se) <- (`runStateT` se0) $ do-        do existentials <- S.filter isExGuarded <$> getM sFormulas-           newExs       <- mapM solveExistential $ S.toList existentials-           modM sFormulas       (S.union $ S.fromList newExs)-           modM sSolvedFormulas (S.union existentials)--        do conjs <- S.filter isConjunction <$> getM sFormulas-           let newConjs = [ gf | GConj (Conj gfs) <- S.toList conjs, gf <- gfs ]-           modM sFormulas       (S.union $ S.fromList newConjs)-           modM sSolvedFormulas (S.union conjs)--        do gfs  <- S.toList <$> getM sFormulas-           lems <- S.toList <$> getM sLemmas-           let clauses = filter isAllGuarded $ gfs ++ lems-               newSuccs = [ gf | cl <- clauses-                               , gf <- solveImplication hnd se0 cl ]-           modM sFormulas (S.union $ S.fromList newSuccs)--        -- solve all atoms in guarded formulas by moving them to the graph-        fms <- S.toList <$> getM sFormulas-        eqs <- fmap catMaybes $ forM fms $ \fm -> case fm of-          GAto ato -> do-            modM sSolvedFormulas (S.insert fm)-            case bvarToLVar ato of-              EqE s t -- only add non-trivial equalities-                | not (s == t) -> return $ Just $ Equal s t-                | otherwise     -> return Nothing-              EdgeA (viewTerm -> Lit (Var i), v) (viewTerm -> Lit (Var j), u) -> do-                modM sEdges $ S.insert $ Edge (i, v) (j, u)-                return Nothing-              EdgeA _ _ ->-                error $ "saturateGuarded: ill-formed edge atom: " ++ show ato-              ato' ->-                modM sAtoms (S.insert ato') >> return Nothing--          _ -> return Nothing--        -- remove solved formulas from open formulas.-        solved <- getM sSolvedFormulas-        modM sFormulas (`S.difference` solved)--        -- return new equality and less atoms-        return eqs--    -- check if there was a change.-    if (null eqs && get sFormulas       se0 == get sFormulas       se-                 && get sSolvedFormulas se0 == get sSolvedFormulas se)-      then return Nothing-      else return (Just (eqs, se))---- | @solveExistential ex@ converts the existentially quantified variables into--- free variables.-solveExistential :: MonadFresh m => LNGuarded -> m LNGuarded-solveExistential gf0 = do-  Just (_, gf) <- openExGuarded gf0-  return gf---- | @solveImplication se imp@ returns the list of guarded formulas that are--- implied by @se@.-solveImplication :: MaudeHandle -> Sequent -> LNGuarded -> [LNGuarded]-solveImplication hnd se gf = -    map (unskolemizeLNGuarded . flip applySkGuarded suc) substs-  where-   (suc,substs) = satisfyingSubsts hnd se gf---- | @satisfyingSubsts se gf@ returns all satisfying substitutions for the--- antecedent of gf. This function expects a clause gf and fails with an error--- otherwise.-satisfyingSubsts :: MaudeHandle -> Sequent -> LNGuarded -> (SkGuarded, [SkSubst])-satisfyingSubsts hnd se gf0 =-    ( succedent-    , candidateSubsts emptySubst [ (i,f) | (Action i f) <- antecedent ]-    )-  where-    -- skolemize and open guarded all-quantification-    gf                                = skolemizeGuarded gf0-    Just (_ss, antecedent, succedent) = openAllGuarded gf `evalFresh` avoid gf--    -- the actions present in the sequent-    sequentActions = -        ((skolemizeTerm . varTerm) *** skolemizeFact) <$> sActions se--    -- candidate substitutions such that the antecedent is implied by @se@-    candidateSubsts subst []     = do-        guard (all (atomHolds subst) antecedent) -        return subst-    candidateSubsts subst (a:as) = do-        seAct  <- sequentActions-        subst' <- (`runReader` hnd) $ matchAction seAct (applySkAction subst a)-        candidateSubsts (compose subst' subst) as-  -    -- cache predicates-    dedBefore = deducibleBefore se-    hapBefore = happensBefore se--    atomHolds subst ato = case unskolemizeTerm . applySkTerm subst <$> ato of-        Action _ _                                               -> True     -- correct by construction-        EqE t s                                                  -> t == s   -- compare terms modulo AC-        Last i                                                   -> Last i `S.member` get sAtoms se-        DedBefore t (viewTerm -> Lit (Var i))                    -> t `dedBefore` i-        Less (viewTerm -> Lit (Var i)) (viewTerm -> Lit (Var j)) -> i `hapBefore` j-        EdgeA (viewTerm -> Lit (Var i), v) (viewTerm -> Lit (Var j), u) -> -            Edge (i, v) (j, u) `S.member` get sEdges se-        -- play it safe and sound: all other atoms don't hold-        _                                                        -> False----- Find open goals----------------------- | All open disjunction goals.------ We assume that solved formulas have been removed from sFormulas-openDisjunctionGoals :: Sequent -> [Goal]-openDisjunctionGoals se = do-  GDisj d <- filter (/= gfalse) $ S.toList $ get sFormulas se-  return $ DisjG d---- | Consequents of clauses that could be added to the sequent.-openImplicationGoals :: MaudeHandle -> Sequent -> [Goal]-openImplicationGoals hnd se = do-    clause <- filter isAllGuarded $ S.toList $ get sFormulas se-    conseq <- solveImplication hnd se clause-    guard $ -        all (conseq `S.notMember`) [get sSolvedFormulas se, get sFormulas se]-    return $ ImplG conseq----- Skolemization of terms without bound variables.--------------------------------------------------- skolemizeTerm :: VTerm Name LVar -> SkTerm--skolemizeTerm :: LNTerm -> SkTerm-skolemizeTerm = fmapTerm conv- where-  conv :: Lit Name LVar -> Lit SkConst LVar-  conv (Var v) = Con (SkConst v)-  conv (Con n) = Con (SkName n)--skolemizeFact :: LNFact -> Fact SkTerm-skolemizeFact = fmap skolemizeTerm--skolemizeAtom :: BLAtom -> BSkAtom-skolemizeAtom = fmap skolemizeBTerm--skolemizeGuarded :: LNGuarded -> SkGuarded-skolemizeGuarded = mapGuardedAtoms (const skolemizeAtom)--unskolemizeTerm :: SkTerm -> VTerm Name LVar-unskolemizeTerm t = fmapTerm conv t- where-  conv :: Lit SkConst LVar -> Lit Name LVar-  conv (Con (SkConst x)) = Var x-  conv (Var v)           = error $ "unskolemizeBTerm: free variable " ++-                                   show v++" found in "++show t-  conv (Con (SkName n))  = Con n--applySkTerm :: SkSubst -> SkTerm -> SkTerm-applySkTerm subst t = applyVTerm subst t--applySkFact :: SkSubst -> SkFact -> SkFact-applySkFact subst = fmap (applySkTerm subst) --applySkAction :: SkSubst -> (SkTerm,SkFact) -> (SkTerm,SkFact)-applySkAction subst (t,f) = (applySkTerm subst t, applySkFact subst f)----- Skolemization of terms wit bound variables.-------------------------------------------------skolemizeBTerm :: VTerm Name BLVar -> BSkTerm-skolemizeBTerm = fmapTerm conv- where-  conv :: Lit Name BLVar -> Lit SkConst BLVar-  conv (Var (Free x))  = Con (SkConst x)-  conv (Var (Bound b)) = Var (Bound b)-  conv (Con n)         = Con (SkName n)--unskolemizeBTerm :: BSkTerm -> VTerm Name BLVar-unskolemizeBTerm t = fmapTerm conv t- where-  conv :: Lit SkConst BLVar -> Lit Name BLVar-  conv (Con (SkConst x)) = Var (Free x)-  conv (Var (Bound b))   = Var (Bound b)-  conv (Var (Free v))    = error $ "unskolemizeBTerm: free variable " ++-                                   show v++" found in "++show t-  conv (Con (SkName n))  = Con n--unskolemizeBLAtom :: BSkAtom -> BLAtom-unskolemizeBLAtom = fmap unskolemizeBTerm--unskolemizeLNGuarded :: SkGuarded -> LNGuarded-unskolemizeLNGuarded = mapGuardedAtoms (const unskolemizeBLAtom)--applyBSkTerm :: SkSubst -> VTerm SkConst BLVar -> VTerm SkConst BLVar-applyBSkTerm subst t = go t-      where-        go (viewTerm -> Lit l)     = applyBLLit l-        go (viewTerm -> FApp o as) = fApp o (map go as)-        applyBLLit :: Lit SkConst BLVar -> VTerm SkConst BLVar-        applyBLLit l@(Var (Free v)) =-            maybe (lit l) (fmapTerm (fmap Free)) (imageOf subst v)-        applyBLLit l                = lit l--applyBSkAtom :: SkSubst -> Atom (VTerm SkConst BLVar) -> Atom (VTerm SkConst BLVar)-applyBSkAtom subst = fmap (applyBSkTerm subst)--applySkGuarded :: SkSubst -> LGuarded SkConst -> LGuarded SkConst-applySkGuarded subst = mapGuardedAtoms (const $ applyBSkAtom subst)---- Matching--------------matchAction :: (SkTerm, SkFact) ->  (SkTerm, SkFact) -> WithMaude [SkSubst]-matchAction (i1,Fact f1 t1) (i2,Fact f2 t2)-  | f1 == f2 && length t1 == length t2-  = matchLTerm sortOfSkol (zipWith MatchWith (i1:t1) (i2:t2))-  | otherwise = return []- where-  sortOfSkol (SkName  n)  = sortOfName n-  sortOfSkol (SkConst v)  = lvarSort v---{---- Test----------parseFormula = get lFormulaE . either (error "parsing failed") id . parseLemma--t1 = parseFormula-       "lemma test1:\-        \ \"\-        \ All y z #i #j. (A(y)@#j & B(z)@#i) ==> (C(y,z) @ #i) & (D(y,z) @ #j) \-        \ \""--t2 = parseFormula-       "lemma test1:\-        \ \"\-        \ All y #i #j. (A(y)@#j & B(y1)@#i) ==> (C(y) @ #i) & (D(y) @ #j) \-        \ \""----        \  All x #i.  A(x)@i ==> Ex y #j. B(y)@j\---gas = [(skolemizeTerm $ i1, skolemizeFact $ Fact (ProtoFact "A") [y1]),-       (skolemizeTerm $ i1, skolemizeFact $ Fact (ProtoFact "B") [y1]),-       (skolemizeTerm $ i2, skolemizeFact $ Fact (ProtoFact "B") [y3])-      ]--t1_g = fromJust $ convert False t1-t2_g = fromJust $ convert False t2--t3 = putStrLn $ render $ prettyGuarded $ t1_g--t4 = mapM_ (putStrLn . render . prettyGuarded) $ solveImplication t1_g gas--}
− src/Theory/Proof/Types.hs 
@@ -1,843 +0,0 @@-{-# LANGUAGE TypeOperators, StandaloneDeriving, DeriveDataTypeable, TemplateHaskell #-}-{-# LANGUAGE TemplateHaskell, ViewPatterns #-}--- |--- Copyright   : (c) 2010-2012 Benedikt Schmidt & Simon Meier--- License     : GPL v3 (see LICENSE)--- --- Maintainer  : Simon Meier <iridcode@gmail.com>--- Portability : GHC only------ Common types for reasoning about sequents: Graph part of a sequent,--- clauses, and equation store.------ NOTE that sequents are what we call constraint systems in CSF'12 paper.-module Theory.Proof.Types (--  -- * Graph part of a sequent-    NodeId-  , NodePrem-  , NodeConc-  , Edge(..)-  , MsgEdge(..)-  , Chain(..)--  -- * The first-order logic part of a sequent---  -- ** Typing and equation store-  , SplitId--  , EqStore(..)-  , emptyEqStore-  , eqsSubst-  , eqsConj--  -- ** Equalitiy constraint conjunctions-  , falseEqConstrConj--  -- ** Queries-  , eqsIsFalse--  -- * Goals-  , Goal(..)-  , isActionGoal-  , isPremiseGoal-  , isPremDnKGoal-  , isPremUpKGoal-  , isChainGoal-  , isSplitGoal-  , isDisjGoal--  -- * Keeping track of typing-  , CaseDistKind(..)--  -- * Sequents-  , Sequent(..)-  , emptySequent--  -- ** Accessors-  , sNodes-  , sEdges-  , sMsgEdges-  , sChains-  , sEqStore-  , sAtoms-  , sFormulas-  , sSolvedFormulas-  , sLemmas-  , sSubst-  , sConjDisjEqs -  , sCaseDistKind--  -- ** Queries-  , sLessAtoms-  , sActionAtoms-  , sLastAtoms-  , sDedBeforeAtoms-  , sActions-  , sRawEdgeRel-  , sRawLessRel-  , sRawGreaterRel-  , deducibleBefore-  , happensBefore--  , nodeRule-  , nodeConcFact-  , nodeConcNode-  , nodePremNode-  , nodePremFact-  , resolveNodePremFact-  -- , resolveNodePremMsg-  , resolveNodeConcFact-  -- , resolveNodeConcMsg--  -- * Pretty-printing-  , prettyNodeId-  , prettyNode-  , prettyNodePrem-  , prettyNodeConc-  , prettyEdge-  , prettyMsgEdge-  , prettyChain--  , prettyEqStore--  , prettyGoal-  , prettySequent-  , prettyNonGraphSequent--  -- * Proof context-  , ProofContext(..)-  , InductionHint(..)-  , SequentTraceQuantifier(..)--  , pcSignature-  , pcRules-  , pcCaseDists-  , pcCaseDistKind-  , pcUseInduction-  , pcTraceQuantifier--  -- ** Classified rules-  , ClassifiedRules(..)-  , emptyClassifiedRules-  , crConstruct-  , crDestruct-  , crProtocol-  , joinAllRules-  , nonSilentRules--  -- ** Big-step case distinctions-  -- | See the module "Theory.Proof.CaseDistinction" for ways-  -- to construct case distinctions.-  , CaseDistinction(..)-  -  , cdGoal-  , cdCases--  -- * Convenience exports-  , module Theory.Rule-  , module Theory.Formula-  , module Theory.Signature-  , module Logic.Connectives-  , module Theory.Proof.Guarded-  ) where--import           Prelude hiding ( (.), id )--import           Data.Maybe (mapMaybe, fromMaybe)-import qualified Data.Set         as S-import qualified Data.Map         as M-import qualified Data.DAG.Simple  as D-import           Data.Monoid (Monoid(..))-import           Data.Generics-import qualified Data.Label                 as L-import           Data.Label                 hiding (get)-import           Data.DeriveTH-import           Data.Binary--import           Control.DeepSeq-import           Control.Category-import           Control.Basics--import           Text.PrettyPrint.Class--import           Logic.Connectives--import           Theory.Pretty-import           Theory.Rule-import           Theory.Proof.Guarded-import           Theory.Formula-import           Theory.Signature----------------------------------------------------------------------------------- Graph part of a sequent                                                  ------------------------------------------------------------------------------------- | The graph part of our sequent consists of nodes labelled with instances of--- rules modulo AC. We identify these nodes using 'NodeId's.-type NodeId = LVar---- | A premise of a node.-type NodePrem = (NodeId, PremIdx)---- | A conclusion of a node.-type NodeConc = (NodeId, ConcIdx)---- | A labeled edge in a derivation graph.-data Edge = Edge {-      eSrc :: NodeConc-    , eTgt :: NodePrem-    }-  deriving (Show, Ord, Eq, Data, Typeable)---- | A message edge.-data MsgEdge = MsgEdge {-      meSrc  :: NodeConc-    , meTgt  :: NodePrem-    }-  deriving (Show, Ord, Eq, Data, Typeable)---- | A chain always starts at a rule with only one conclusion.-data Chain = Chain {-      cSrc :: NodeConc-    , cTgt :: NodePrem-    }-  deriving (Show, Ord, Eq, Data, Typeable)----- Instances---------------instance Apply Edge where-    apply subst (Edge from to) = Edge (apply subst from) (apply subst to)--instance Apply MsgEdge where-    apply subst (MsgEdge from to) = MsgEdge (apply subst from) (apply subst to)--instance Apply Chain where-    apply subst (Chain from to) = Chain (apply subst from) (apply subst to)--instance HasFrees Edge where-    foldFrees f (Edge x y) = foldFrees f x `mappend` foldFrees f y-    mapFrees  f (Edge x y) = Edge <$> mapFrees f x <*> mapFrees f y--instance HasFrees MsgEdge where-    foldFrees f (MsgEdge x y) = foldFrees f x `mappend` foldFrees f y-    mapFrees  f (MsgEdge x y) = MsgEdge <$> mapFrees f x <*> mapFrees f y--instance HasFrees Chain where-    foldFrees f (Chain x y) = foldFrees f x `mappend` foldFrees f y-    mapFrees  f (Chain x y) = Chain <$> mapFrees f x <*> mapFrees f y------------------------------------------------------------------------------------ The first-order logic part of a sequent                                  -------------------------------------------------------------------------------------------------------------------------------------------------------------------- Typing and equation store                                                ------------------------------------------------------------------------------------- | Index of disjunction in equation store-type SplitId = Int---- FIXME: Make comment parse.------ The semantics of an equation store--- > EqStore sigma_free--- >         [ [sigma_i1,..,sigma_ik_i] | i <- [1..l] ]--- where sigma_free = {t1/x1, .., tk/xk} is--- >    (x1 = t1 /\ .. /\ xk = tk)--- > /\_{i in [1..l]}--- >    ([|sigma_i1|] \/ .. \/ [|sigma_ik_1|] \/ [|mtinfo_i|]--- where @[|{t_1/x_1,..,t_l/x_l}|] = EX vars(t1,..,tl). x_1 = t1 /\ .. /\ x_l = t_l@.--- Note that the 'LVar's in the range of a substitution are interpreted as--- fresh variables, i.e., different by construction from the x_i which are--- free variables.------ The variables in the domain of the substitutions sigma_ij and all--- variables in sigma_free are free (usually globally existentially quantified).--- We use Conj [] as a normal form to denote True and Conj [Disj []]--- as a normal form to denote False.--- We say a variable @x@ is constrained by a disjunction if there is a substition--- @s@ in the disjunction with @x `elem` dom s@.-data EqStore = EqStore {-      _eqsSubst :: LNSubst-    , _eqsConj  :: Conj (S.Set LNSubstVFresh)-    }-  deriving( Eq, Ord )--$(mkLabels [''EqStore])---- | @emptyEqStore@ is the empty equation store.-emptyEqStore :: EqStore-emptyEqStore = EqStore emptySubst (Conj [])---- | @True@ iff the 'EqStore' is contradictory.-eqsIsFalse :: EqStore -> Bool-eqsIsFalse = (== falseEqConstrConj) . L.get eqsConj---- | The false typing conjunction.-falseEqConstrConj :: Conj (S.Set (LNSubstVFresh))-falseEqConstrConj = Conj [S.empty]----- Instances---------------instance HasFrees EqStore where-    foldFrees f (EqStore subst substs) = foldFrees f subst `mappend` foldFrees f substs-    mapFrees f (EqStore subst substs) = EqStore <$> mapFrees f subst <*> mapFrees f substs------------------------------------------------------------------------------------ New goaling infrastructure------------------------------------------------------------------------------------------------------------------------------------------------------------------- Goals----------------------------------------------------------------------------------- | A 'Goal' denotes that a constraint reduction rule is applicable, which --- might result in case splits. We either use a heuristic to decide what goal--- to solve next or leave the choice to user (in case of the interactive UI).-data Goal = -       ActionG LVar LNFact-       -- ^ An action that must exist in the trace.-     | PremiseG NodePrem LNFact Bool-       -- ^ A premise that must have an incoming direct edge. The 'Bool'-       -- argument is 'True' if this premise is marked as a loop-breaker;-       -- i.e., if care must be taken to avoid solving such a premise too-       -- often.-     | PremDnKG NodePrem-       -- ^ A KD goal that must be solved using a destruction chain.-     | PremUpKG NodePrem LNTerm-       -- ^ A KU goal requiring a term built using pairing, inversion, or-       -- multiplication. 'PremUpKG p m' denotes that premise 'p' requires-       -- the term 'm' as in input to construct its actual term.-     | ChainG Chain-       -- A destruction chain that does not start from a message variable.-     | SplitG SplitId-       -- ^ A case split over equalities.-     | DisjG (Disj LNGuarded)-       -- ^ A case split over a disjunction.-     | ImplG LNGuarded-       -- ^ The consequent of a universally quantified clause that could be-       -- added to the sequent. For debugging mode only; currently commented-       -- out.-     deriving( Eq, Ord, Show )---- Indicators----------------isActionGoal :: Goal -> Bool-isActionGoal (ActionG _ _) = True-isActionGoal _             = False--isPremiseGoal :: Goal -> Bool-isPremiseGoal (PremiseG _ _ _) = True-isPremiseGoal _                = False--isPremDnKGoal :: Goal -> Bool-isPremDnKGoal (PremDnKG _) = True-isPremDnKGoal _            = False--isPremUpKGoal :: Goal -> Bool-isPremUpKGoal (PremUpKG _ _) = True-isPremUpKGoal _              = False--isChainGoal :: Goal -> Bool-isChainGoal (ChainG _) = True-isChainGoal _          = False--isSplitGoal :: Goal -> Bool-isSplitGoal (SplitG _) = True-isSplitGoal _          = False--isDisjGoal :: Goal -> Bool-isDisjGoal (DisjG _) = True-isDisjGoal _         = False------ Instances---------------instance HasFrees Goal where-    foldFrees f goal = case goal of-        ActionG i fa          -> foldFrees f i `mappend` foldFrees f fa-        PremiseG p fa mayLoop -> foldFrees f p `mappend` foldFrees f fa `mappend` foldFrees f mayLoop-        PremDnKG p            -> foldFrees f p-        PremUpKG p m          -> foldFrees f p `mappend` foldFrees f m-        ChainG ch             -> foldFrees f ch-        SplitG i              -> foldFrees f i-        DisjG x               -> foldFrees f x-        ImplG x               -> foldFrees f x--    mapFrees f goal = case goal of-        ActionG i fa          -> ActionG  <$> mapFrees f i <*> mapFrees f fa-        PremiseG p fa mayLoop -> PremiseG <$> mapFrees f p <*> mapFrees f fa <*> mapFrees f mayLoop-        PremDnKG p            -> PremDnKG <$> mapFrees f p-        PremUpKG p m          -> PremUpKG <$> mapFrees f p <*> mapFrees f m-        ChainG ch             -> ChainG   <$> mapFrees f ch-        SplitG i              -> SplitG   <$> mapFrees f i-        DisjG x               -> DisjG    <$> mapFrees f x-        ImplG x               -> ImplG    <$> mapFrees f x--instance Apply Goal where-    apply subst goal = case goal of-        ActionG i fa          -> ActionG  (apply subst i)     (apply subst fa)-        PremiseG p fa mayLoop -> PremiseG (apply subst p)     (apply subst fa) (apply subst mayLoop)-        PremDnKG p            -> PremDnKG (apply subst p)-        PremUpKG p m          -> PremUpKG (apply subst p)     (apply subst m)-        ChainG ch             -> ChainG   (apply subst ch)-        SplitG i              -> SplitG   (apply subst i)-        DisjG x               -> DisjG    (apply subst x)-        ImplG x               -> ImplG    (apply subst x)------------------------------------------------------------------------------------ Keeping track of what case distinctions are allowed.----------------------------------------------------------------------------------- | Case dinstinction kind that are allowed. The order of the kinds--- corresponds to the subkinding relation: untyped < typed.-data CaseDistKind = UntypedCaseDist | TypedCaseDist-       deriving( Eq, Ord )--instance Show CaseDistKind where-    show UntypedCaseDist = "untyped"-    show TypedCaseDist   = "typed"---instance Apply CaseDistKind where-    apply = const id--instance HasFrees CaseDistKind where-    foldFrees = const mempty-    mapFrees  = const pure----------------------------------------------------------------------------------- Sequents                                                                 ------------------------------------------------------------------------------------- | A sequent / constraint system.----data Sequent = Sequent {-      _sNodes          :: M.Map NodeId RuleACInst-    , _sEdges          :: S.Set Edge-    , _sMsgEdges       :: S.Set MsgEdge-    , _sChains         :: S.Set Chain-    , _sEqStore        :: EqStore-    , _sAtoms          :: S.Set LNAtom-    , _sFormulas       :: S.Set LNGuarded-    , _sSolvedFormulas :: S.Set LNGuarded-    , _sLemmas         :: S.Set LNGuarded-    , _sCaseDistKind   :: CaseDistKind-    }-    deriving( Eq, Ord )--$(mkLabels [''Sequent])---- | The empty sequent. Logically equivalent to true.-emptySequent :: CaseDistKind -> Sequent-emptySequent = Sequent -  M.empty S.empty S.empty S.empty emptyEqStore S.empty S.empty S.empty S.empty---- Custom accessors for atoms---------------------------------- | All actions that hold in a sequent.-sActions :: Sequent -> [(NodeId, LNFact)]-sActions se = -    sActionAtoms se <|> do (i, ru) <- M.toList $ L.get sNodes se-                           (,) i <$> L.get rActs ru---- | The less-relation.-sLessAtoms :: Sequent -> [(NodeId, NodeId)]---- | The actions.-sActionAtoms :: Sequent -> [(NodeId, LNFact)]---- | The last nodes.-sLastAtoms :: Sequent -> [NodeId]---- | The deduced before atoms.-sDedBeforeAtoms :: Sequent -> [(LNTerm, NodeId)]--(sLessAtoms, sActionAtoms, sLastAtoms, sDedBeforeAtoms) = -    (accessor aLess, accessor aAction, accessor aLast, accessor aDedBefore)-  where-    accessor :: (LNAtom -> Maybe a) -> Sequent -> [a]-    accessor f = mapMaybe f . S.toList . L.get sAtoms--    malformed ato = error $ "malformed atom in sequent: " ++ show ato--    aLess (Less (viewTerm -> Lit (Var from)) (viewTerm -> Lit (Var to))) = Just (from, to)-    aLess ato@(Less _ _)                         = malformed ato-    aLess _                                      = Nothing--    aAction (Action (viewTerm -> Lit (Var i)) fa) = Just (i, fa)-    aAction ato@(Action _ _)          = malformed ato-    aAction _                         = Nothing--    aLast (Last (viewTerm -> Lit (Var i))) = Just i-    aLast ato@(Last _)         = malformed ato-    aLast _                    = Nothing--    aDedBefore (DedBefore t (viewTerm -> Lit (Var i))) = Just (t, i)-    aDedBefore ato@(DedBefore _ _)         = malformed ato-    aDedBefore _                           = Nothing---- | @(from,to)@ is in @sRawEdgeRel se@ iff we can prove that there is an--- edge-path from @from@ to @to@ in @se@ without appealing to transitivity.-sRawEdgeRel :: Sequent -> [(NodeId, NodeId)]-sRawEdgeRel se =-    map (nodeConcNode *** nodePremNode)-      ([ (from, to) | Edge from to <- S.toList $ L.get sEdges se ] ++-       [ (from, to) | MsgEdge from to <- S.toList $ L.get sMsgEdges se ] ++-       [ (from, to) | Chain from to <- S.toList $ L.get sChains se ])---- | @(from,to)@ is in @sRawLessRel se@ iff we can prove that there is a path--- (possibly using the 'Less' relation) from @from@ to @to@ in @se@ without--- appealing to transitivity.-sRawLessRel :: Sequent -> [(NodeId,NodeId)]-sRawLessRel se = sLessAtoms se ++ sRawEdgeRel se---- | 'sRawGreaterRel' is the inverse of 'sRawLessRel'. -sRawGreaterRel :: Sequent -> [(NodeId,NodeId)]-sRawGreaterRel = map (\(x,y) -> (y,x)) . sRawLessRel---- | Returns a predicate that is 'True' iff the first argument happens before--- the second argument in all models of the sequent.-happensBefore :: Sequent -> (NodeId -> NodeId -> Bool)-happensBefore se =-    check -- lessRel is cached for partial applications-  where-    lessRel   = sRawLessRel se-    check i j = j `S.member` D.reachableSet [i] lessRel---- | Returns a predicate that is 'True' iff the given term is deducible--- before the given node in all models of the sequent.-deducibleBefore :: Sequent -> (LNTerm -> NodeId -> Bool)-deducibleBefore se = -    check -- lessRel is cached for partial applications-  where-    lessRel = sRawLessRel se-    check t i = -        i `S.member` D.reachableSet startNodes lessRel-      where-        startNodes = -            [ j | (t', j) <- sDedBeforeAtoms se, t == t' ] ++-            do (j, ru) <- M.toList $ L.get sNodes se-               fa <- L.get rPrems ru-               case kFactView fa of-                 Just (_, _, m) | t `elem` input m -> return j-                 _                                 -> []----- Instances for sequents----------------------------instance HasFrees Sequent where-    foldFrees fun (Sequent a b c d e f g h i j) =-        foldFrees fun a `mappend`-        foldFrees fun b `mappend`-        foldFrees fun c `mappend`-        foldFrees fun d `mappend`-        foldFrees fun e `mappend`-        foldFrees fun f `mappend`-        foldFrees fun g `mappend`-        foldFrees fun h `mappend`-        foldFrees fun i `mappend`-        foldFrees fun j--    mapFrees fun (Sequent a b c d e f g h i j) =-        Sequent <$> mapFrees fun a-                <*> mapFrees fun b-                <*> mapFrees fun c-                <*> mapFrees fun d-                <*> mapFrees fun e-                <*> mapFrees fun f-                <*> mapFrees fun g-                <*> mapFrees fun h-                <*> mapFrees fun i-                <*> mapFrees fun j---- Accessors----------------- | @nodeRule v@ accesses the rule label of node @v@ under the assumption that--- it is present in the sequent.-nodeRule :: NodeId -> Sequent -> RuleACInst-nodeRule v se = -    fromMaybe errMsg $ M.lookup v $ L.get sNodes se-  where-    errMsg = error $ -        "nodeRule: node '" ++ show v ++ "' does not exist in sequent\n" ++-        render (nest 2 $ prettySequent se)----- | @nodePremFact prem se@ computes the fact associated to premise @prem@ in--- sequent @se@ under the assumption that premise @prem@ is a a premise in--- @se@.-nodePremFact :: NodePrem -> Sequent -> LNFact-nodePremFact (v, i) se = L.get (rPrem i) $ nodeRule v se---- | @nodePremNode prem@ is the node that this premise is referring to.-nodePremNode :: NodePrem -> NodeId-nodePremNode = fst---- | All facts associated to this node premise.-resolveNodePremFact :: NodePrem -> Sequent -> Maybe LNFact-resolveNodePremFact (v, i) se = lookupPrem i =<< M.lookup v (L.get sNodes se)--{---- | All msg fact premises required by the sequent for the given node premise.-resolveNodePremMsg :: NodePrem -> Sequent -> Maybe LTerm-resolveNodePremMsg prem = msgFactTerm <=< resolveNodePremFact prem--}-    --- | The fact associated with this node conclusion, if there is one.-resolveNodeConcFact :: NodeConc -> Sequent -> Maybe LNFact-resolveNodeConcFact (v, i) se = lookupConc i =<< M.lookup v (L.get sNodes se)--{---- | The msg fact provided by the sequent for the given node conclusion-resolveNodeConcMsg :: NodeConc -> Sequent -> Maybe LTerm-resolveNodeConcMsg conc = msgFactTerm <=< resolveNodeConcFact conc--}---- | @nodeConcFact (NodeConc (v, i))@ accesses the @i@-th conclusion of the--- rule associated with node @v@ under the assumption that @v@ is labeled with--- a rule that has an @i@-th conclusion.-nodeConcFact :: NodeConc -> Sequent -> LNFact-nodeConcFact (v, i) = L.get (rConc i) . nodeRule v---- | 'nodeConcNode' @c@ compute the node-id of the node conclusion @c@.-nodeConcNode :: NodeConc -> NodeId-nodeConcNode = fst ---- | Label to access the free substitution of the equation store.-sSubst :: Sequent :-> LNSubst-sSubst = eqsSubst . sEqStore---- | Label to access the conjunction of disjunctions of fresh substutitution in--- the equation store.-sConjDisjEqs :: Sequent :-> Conj (S.Set (LNSubstVFresh))-sConjDisjEqs = eqsConj . sEqStore------------------------------------------------------------------------------------ Pretty printing                                                          ------------------------------------------------------------------------------------- | Pretty print a node id-prettyNodeId :: Document d => NodeId -> d-prettyNodeId = text . show---- | Pretty print a node.-prettyNode :: HighlightDocument d => (NodeId, RuleACInst) -> d-prettyNode (v,ru) = prettyNodeId v <> colon <-> prettyRuleACInst ru---- | Pretty print a node conclusion.-prettyNodeConc :: HighlightDocument d => NodeConc -> d-prettyNodeConc (v, ConcIdx i) = parens (prettyNodeId v <> comma <-> int i)---- | Pretty print a node premise.-prettyNodePrem :: HighlightDocument d => NodePrem -> d-prettyNodePrem (v, PremIdx i) = parens (prettyNodeId v <> comma <-> int i)---- | Pretty print a edge as @src >-i--j-> tgt@.-prettyEdge :: HighlightDocument d => Edge -> d-prettyEdge (Edge c p) = -    prettyNodeConc c <-> operator_ ">-->" <-> prettyNodePrem p---- | Pretty print a edge as @src >-i--j-> tgt@.-prettyMsgEdge :: HighlightDocument d => MsgEdge -> d-prettyMsgEdge (MsgEdge c p) = -    prettyNodeConc c <-> operator_ "-->>" <-> prettyNodePrem p---- | Pretty print a chain as @src ~~> tgt@.-prettyChain :: HighlightDocument d => Chain -> d-prettyChain (Chain c p) = -    prettyNodeConc c <-> operator_ "~~>" <-> prettyNodePrem p---- | Pretty print a sequent-prettySequent :: HighlightDocument d => Sequent -> d-prettySequent se = vcat $ -    map combine-      [ ("nodes",     vcat $ map prettyNode $ M.toList $ L.get sNodes se)-      , ("edges",     commasep $ map prettyEdge $ S.toList $ L.get sEdges se)-      , ("msg-edges", commasep $ map prettyMsgEdge $ S.toList $ L.get sMsgEdges se)-      , ("chains",    commasep $ map prettyChain $ S.toList $ L.get sChains se)-      ]-    ++ [prettyNonGraphSequent se]-  where-    combine (header, d) = fsep [keyword_ header <> colon, nest 2 d]-    commasep = fsep . punctuate comma---- | Pretty print the non-graph part of the sequent; i.e. equation store and--- clauses.-prettyNonGraphSequent :: HighlightDocument d => Sequent -> d-prettyNonGraphSequent se = foldr ($--$) emptyDoc $ map combine  -  [ ("atoms",           ppAtoms $ S.toList $ L.get sAtoms se)-  , ("allowed cases",   text $ show $ L.get sCaseDistKind se)-  , ("formulas",        foldr ($--$) emptyDoc $ map prettyGuarded $ S.toList $ L.get sFormulas se)-  , ("equations",       prettyEqStore $ L.get sEqStore se)-  , ("solved formulas", foldr ($--$) emptyDoc $ map prettyGuarded $ S.toList $ L.get sSolvedFormulas se)-  , ("lemmas",          foldr ($--$) emptyDoc $ map prettyGuarded $ S.toList $ L.get sLemmas se)-  ]-  where-    combine (header, d) = fsep [keyword_ header <> colon, nest 2 d]-    ppAtoms             = fsep . punctuate comma . map prettyNAtom----- | Pretty print an equation store-prettyEqStore :: HighlightDocument d => EqStore -> d-prettyEqStore eqs@(EqStore subst (Conj disjs)) = vcat $-  [if eqsIsFalse eqs then text "CONTRADICTORY" else emptyDoc] ++-  map combine-    [ ("subst", vcat $ prettySubst (text . show) (text . show) subst)-    , ("conj",  numbered' $ map ppDisj disjs)-    ]-  where-    combine (header, d) = fsep [keyword_ header <> colon, nest 2 d]-    ppDisj substs =-        numbered' conjs-      where -        conjs = map ppConj (S.toList substs)-        ppConj = vcat . map prettyEq . substToListVFresh-        prettyEq (a,b) = -          prettyNTerm (lit (Var a)) $$ nest (6::Int) (opEqual <-> prettyNTerm b)-        --- | Pretty print a goal.-prettyGoal :: HighlightDocument d => Goal -> d-prettyGoal (ActionG i fa)          = prettyNAtom (Action (varTerm i) fa)-prettyGoal (ChainG ch)             = prettyChain ch-prettyGoal (PremiseG p fa mayLoop) =-    prettyNodePrem p <> brackets (prettyLNFact fa) <->-    (if mayLoop then comment_ "/* may loop */" else emptyDoc)-prettyGoal (PremDnKG p)            = text "KD" <> parens (prettyNodePrem p)-prettyGoal (ImplG gf)              =-    (text "Consequent" <>) $ nest 1 $ parens $ prettyGuarded gf-prettyGoal (DisjG (Disj gfs)) = (text "Disj" <>) $ fsep $-    punctuate (operator_ " |") (map (nest 1 . parens . prettyGuarded) gfs)-prettyGoal (PremUpKG p m)  =-    text "KU" <> parens (prettyNodePrem p <> comma <-> prettyLNTerm m)-prettyGoal (SplitG x) =-    text "splitEqs" <> parens (text $ show (succ x))----- Additional Show instances moved here due to TemplateHaskell splicing rules--------------------------------------------------------------------------------instance Show EqStore where-  show = render . prettyEqStore--deriving instance Show Sequent--------------------------------------------------------------------------- ClassifiedRules-------------------------------------------------------------------------data ClassifiedRules = ClassifiedRules-     { _crProtocol      :: [RuleAC] -- all protocol rules-     , _crDestruct      :: [RuleAC] -- destruction rules-     , _crConstruct     :: [RuleAC] -- construction rules-     }-     deriving( Eq, Ord, Show )--$(mkLabels [''ClassifiedRules])---- | The empty proof rule set.-emptyClassifiedRules :: ClassifiedRules-emptyClassifiedRules = ClassifiedRules [] [] []---- | @joinAllRules rules@ computes the union of all rules classified in--- @rules@.-joinAllRules :: ClassifiedRules -> [RuleAC]-joinAllRules (ClassifiedRules a b c) = a ++ b ++ c---- | Extract all non-silent rules.-nonSilentRules :: ClassifiedRules -> [RuleAC]-nonSilentRules = filter (not . null . L.get rActs) . joinAllRules------------------------------------------------------------------------------------ Proof Context----------------------------------------------------------------------------------- | A big-step case distinction.-data CaseDistinction = CaseDistinction-     { _cdGoal     :: LNFact   -- start goal of case distinction-       -- disjunction of named sequents with premise being solved; each name-       -- being the path of proof steps required to arrive at these cases-     , _cdCases    :: Disj ([String], (NodeConc, Sequent))-     }-     deriving( Eq, Ord, Show )---- | Whether we are checking for the existence of a trace satisfiying a the--- current constraint system or whether we're checking that no traces--- satisfies the current constraint system.-data SequentTraceQuantifier = ExistsSomeTrace | ExistsNoTrace-       deriving( Eq, Ord, Show )--data InductionHint = UseInduction | AvoidInduction-       deriving( Eq, Ord, Show )---- | A proof context contains the globally fresh facts, classified rewrite--- rules and the corresponding precomputed premise case distinction theorems.-data ProofContext = ProofContext -       { _pcSignature       :: SignatureWithMaude-       , _pcRules           :: ClassifiedRules-       , _pcCaseDistKind    :: CaseDistKind-       , _pcCaseDists       :: [CaseDistinction]-       , _pcUseInduction    :: InductionHint-       , _pcTraceQuantifier :: SequentTraceQuantifier-       }-       deriving( Eq, Ord, Show )--$(mkLabels [''ProofContext, ''CaseDistinction])----- Instances---------------instance HasFrees CaseDistinction where-    foldFrees f th = -        foldFrees f (L.get cdGoal th)   `mappend` -        foldFrees f (L.get cdCases th)--    mapFrees f th = CaseDistinction <$> mapFrees f (L.get cdGoal th)-                                    <*> mapFrees f (L.get cdCases th)----- NFData------------$( derive makeBinary ''Goal)-$( derive makeBinary ''Chain)-$( derive makeBinary ''MsgEdge)-$( derive makeBinary ''Edge)-$( derive makeBinary ''EqStore)-$( derive makeBinary ''CaseDistKind)-$( derive makeBinary ''Sequent)-$( derive makeBinary ''CaseDistinction)-$( derive makeBinary ''ClassifiedRules)-$( derive makeBinary ''SequentTraceQuantifier)-$( derive makeBinary ''InductionHint)--$( derive makeNFData ''Goal)-$( derive makeNFData ''Chain)-$( derive makeNFData ''MsgEdge)-$( derive makeNFData ''Edge)-$( derive makeNFData ''EqStore)-$( derive makeNFData ''CaseDistKind)-$( derive makeNFData ''Sequent)-$( derive makeNFData ''CaseDistinction)-$( derive makeNFData ''ClassifiedRules)-$( derive makeNFData ''SequentTraceQuantifier)-$( derive makeNFData ''InductionHint)
− src/Theory/Rule.hs 
@@ -1,621 +0,0 @@-{-# LANGUAGE TemplateHaskell, GeneralizedNewtypeDeriving, DeriveDataTypeable, TupleSections, TypeOperators, FlexibleInstances, FlexibleContexts, TypeSynonymInstances #-}--- |--- Copyright   : (c) 2010-2012 Benedikt Schmidt & Simon Meier--- License     : GPL v3 (see LICENSE)--- --- Maintainer  : Simon Meier <iridcode@gmail.com>--- Portability : portable------ Rewriting rules representing protocol execution and intruder deduction. Once--- modulo the full Diffie-Hellman equational theory and once modulo AC.-module Theory.Rule (-  -- * General Rules-    Rule(..)-  , PremIdx(..)-  , ConcIdx(..)--  -- ** Accessors-  , rInfo-  , rPrems-  , rConcs-  , rActs-  , rPrem-  , rConc-  , lookupPrem-  , lookupConc-  , enumPrems-  , enumConcs--  -- ** Genereal protocol and intruder rules-  , RuleInfo(..)-  , ruleInfo--  -- * Protocol Rule Information-  , ProtoRuleName(..)-  , ProtoRuleACInfo(..)-  , pracName-  , pracVariants-  , pracLoopBreakers-  , ProtoRuleACInstInfo(..)-  , praciName-  , praciLoopBreakers-  , RuleACConstrs--  -- * Intruder Rule Information-  , IntrRuleACInfo(..)-  -  -- * Concrete Rules-  , ProtoRuleE-  , ProtoRuleAC-  , IntrRuleAC-  , RuleAC-  , RuleACInst--  -- ** Queries-  , HasRuleName(..)-  , isIntruderRule-  , isDestrRule-  , isConstrRule-  , isFreshRule-  , isIRecvRule-  , isISendRule-  , isCoerceRule-  , nfRule-  , isTrivialProtoVariantAC--  -- ** Conversion-  , ruleACToIntrRuleAC-  , ruleACIntrToRuleAC--  -- ** Construction-  , someRuleACInst--  -- ** Unification-  , unifyRuleACInstEqs--  -- * Pretty-Printing-  , showRuleCaseName-  , prettyProtoRuleName-  , prettyRuleName-  , prettyProtoRuleE-  , prettyProtoRuleAC-  , prettyIntrRuleAC-  , prettyIntrRuleACInfo-  , prettyRuleAC-  , prettyLoopBreakers-  , prettyRuleACInst--  -- * Convenience exports-  , module Theory.Fact--  )  where--import           Prelude hiding ( (.), id )--import           Safe-import           Data.List-import           Data.Monoid-import           Data.Foldable (foldMap)-import           Data.Generics -import           Data.DeriveTH-import           Data.Binary--import           Control.DeepSeq-import           Control.Category-import           Control.Basics-import           Control.Monad.Bind-import           Control.Monad.Reader--import           Extension.Data.Label hiding (get)-import qualified Extension.Data.Label as L-import           Logic.Connectives--import           Theory.Fact-import           Theory.Pretty-import           Term.Rewriting.Norm----------------------------------------------------------------------------------- General Rule----------------------------------------------------------------------------------- | Rewriting rules with arbitrary additional information and facts with names--- and logical variables.-data Rule i = Rule {-         _rInfo  :: i-       , _rPrems :: [LNFact]-       , _rConcs :: [LNFact]-       , _rActs  :: [LNFact]-       }-       deriving( Eq, Ord, Show, Data, Typeable )--$(mkLabels [''Rule])---- | An index of a premise. The first premise has index '0'.-newtype PremIdx = PremIdx { getPremIdx :: Int }-  deriving( Eq, Ord, Show, Enum, Data, Typeable, Binary, NFData )---- | An index of a conclusion. The first conclusion has index '0'.-newtype ConcIdx = ConcIdx { getConcIdx :: Int }-  deriving( Eq, Ord, Show, Enum, Data, Typeable, Binary, NFData )---- | @lookupPrem i ru@ returns the @i@-th premise of rule @ru@, if possible.-lookupPrem :: PremIdx -> Rule i -> Maybe LNFact-lookupPrem i = (`atMay` getPremIdx i) . L.get rPrems---- | @lookupConc i ru@ returns the @i@-th conclusion of rule @ru@, if possible.-lookupConc :: ConcIdx -> Rule i -> Maybe LNFact-lookupConc i = (`atMay` getConcIdx i) . L.get rConcs---- | @rPrem i@ is a lens for the @i@-th premise of a rule.-rPrem :: PremIdx -> (Rule i :-> LNFact)-rPrem i = nthL (getPremIdx i) . rPrems---- | @rConc i@ is a lens for the @i@-th conclusion of a rule.-rConc :: ConcIdx -> (Rule i :-> LNFact)-rConc i = nthL (getConcIdx i) . rConcs---- | Enumerate all premises of a rule.-enumPrems :: Rule i -> [(PremIdx, LNFact)]-enumPrems = zip [(PremIdx 0)..] . L.get rPrems---- | Enumerate all conclusions of a rule.-enumConcs :: Rule i -> [(ConcIdx, LNFact)]-enumConcs = zip [(ConcIdx 0)..] . L.get rConcs---- Instances---------------instance Functor Rule where-    fmap f (Rule i ps cs as) = Rule (f i) ps cs as--instance HasFrees i => HasFrees (Rule i) where-    foldFrees f (Rule i ps cs as) = -        (foldFrees f i  `mappend`) $ -        (foldFrees f ps `mappend`) $-        (foldFrees f cs `mappend`) $-        (foldFrees f as)--    mapFrees f (Rule i ps cs as) =-        Rule <$> mapFrees f i -             <*> mapFrees f ps <*> mapFrees f cs <*> mapFrees f as--instance Apply i => Apply (Rule i) where-    apply subst (Rule i ps cs as) = -        Rule (apply subst i) (apply subst ps) (apply subst cs) (apply subst as)--instance Sized (Rule i) where-  size (Rule _ ps cs as) = size ps + size cs + size as----------------------------------------------------------------------------------- Rule information split into intruder rule and protocol rules----------------------------------------------------------------------------------- | Rule information for protocol and intruder rules.-data RuleInfo p i = -         ProtoInfo p-       | IntrInfo i -       deriving( Eq, Ord, Show )---- | @ruleInfo proto intr@ maps the protocol information with @proto@ and the--- intruder information with @intr@.-ruleInfo :: (p -> c) -> (i -> c) -> RuleInfo p i -> c-ruleInfo proto _    (ProtoInfo x) = proto x-ruleInfo _     intr (IntrInfo  x) = intr x----- Instances---------------instance (HasFrees p, HasFrees i) => HasFrees (RuleInfo p i) where-    foldFrees  f = ruleInfo (foldFrees f) (foldFrees f)--    mapFrees   f = ruleInfo (fmap ProtoInfo . mapFrees   f) -                            (fmap IntrInfo . mapFrees   f)--instance (Apply p, Apply i) => Apply (RuleInfo p i) where-    apply subst = ruleInfo (ProtoInfo . apply subst) (IntrInfo . apply subst)------------------------------------------------------------------------------------ Protocol Rule Information----------------------------------------------------------------------------------- | A name of a protocol rule is either one of the special reserved rules or--- some standard rule.-data ProtoRuleName = -         FreshRule-       | StandRule String -- ^ Some standard protocol rule-       deriving( Eq, Ord, Show, Data, Typeable )----- | Information for protocol rules modulo AC. The variants list the possible--- instantiations of the free variables of the rule. The typing is interpreted--- modulo AC; i.e., its variants were also built.-data ProtoRuleACInfo = ProtoRuleACInfo-       { _pracName         :: ProtoRuleName-       , _pracVariants     :: Disj (LNSubstVFresh)-       , _pracLoopBreakers :: [PremIdx]-       }-       deriving( Eq, Ord, Show )---- | Information for instances of protocol rules modulo AC.-data ProtoRuleACInstInfo = ProtoRuleACInstInfo-       { _praciName         :: ProtoRuleName-       , _praciLoopBreakers :: [PremIdx]-       }-       deriving( Eq, Ord, Show )---$(mkLabels [''ProtoRuleACInfo, ''ProtoRuleACInstInfo])----- Instances---------------instance Apply ProtoRuleName where-    apply _ = id--instance HasFrees ProtoRuleName where-    foldFrees  _ = const mempty-    mapFrees   _ = pure--instance Apply PremIdx where-    apply _ = id--instance HasFrees PremIdx where-    foldFrees  _ = const mempty-    mapFrees   _ = pure--instance Apply ConcIdx where-    apply _ = id--instance HasFrees ConcIdx where-    foldFrees  _ = const mempty-    mapFrees   _ = pure--instance HasFrees ProtoRuleACInfo where-    foldFrees f (ProtoRuleACInfo na vari breakers) =-        foldFrees f na `mappend` foldFrees f vari-                       `mappend` foldFrees f breakers-    -    mapFrees f (ProtoRuleACInfo na vari breakers) = -        ProtoRuleACInfo na <$> mapFrees f vari <*> mapFrees f breakers--instance Apply ProtoRuleACInstInfo where-    apply _ = id--instance HasFrees ProtoRuleACInstInfo where-    foldFrees f (ProtoRuleACInstInfo na breakers) =-        foldFrees f na `mappend` foldFrees f breakers-    -    mapFrees f (ProtoRuleACInstInfo na breakers) = -        ProtoRuleACInstInfo na <$> mapFrees f breakers------------------------------------------------------------------------------------ Intruder Rule Information----------------------------------------------------------------------------------- | An intruder rule modulo AC is described by its name.-data IntrRuleACInfo = -    ConstrRule String-  | DestrRule String-  | CoerceRule-  | IRecvRule-  | ISendRule-  | PubConstrRule-  | FreshConstrRule-  deriving( Ord, Eq, Show, Data, Typeable )---- | An intruder rule modulo AC.-type IntrRuleAC = Rule IntrRuleACInfo---- | Converts between these two types of rules, if possible.-ruleACToIntrRuleAC :: RuleAC -> Maybe IntrRuleAC-ruleACToIntrRuleAC (Rule (IntrInfo i) ps cs as) = Just (Rule i ps cs as)-ruleACToIntrRuleAC _                            = Nothing---- | Converts between these two types of rules.-ruleACIntrToRuleAC :: IntrRuleAC -> RuleAC-ruleACIntrToRuleAC (Rule ri ps cs as) = Rule (IntrInfo ri) ps cs as---- Instances---------------instance Apply IntrRuleACInfo where-    apply _ = id--instance HasFrees IntrRuleACInfo where-    foldFrees _ = const mempty-    mapFrees _  = pure------------------------------------------------------------------------------------ Concrete rules----------------------------------------------------------------------------------- | A rule modulo E is always a protocol rule. Intruder rules are specified--- abstractly by their operations generating them and are only available once--- their variants are built.-type ProtoRuleE  = Rule ProtoRuleName---- | A protocol rule modulo AC.-type ProtoRuleAC = Rule ProtoRuleACInfo---- | A rule modulo AC is either a protocol rule or an intruder rule-type RuleAC      = Rule (RuleInfo ProtoRuleACInfo IntrRuleACInfo)---- | A rule instance module AC is either a protocol rule or an intruder rule.--- The info identifies the corresponding rule modulo AC that the instance was--- derived from.-type RuleACInst  = Rule (RuleInfo ProtoRuleACInstInfo IntrRuleACInfo)---- Accessing the rule name------------------------------- | Types that have an associated name.-class HasRuleName t where-  ruleName :: t -> RuleInfo ProtoRuleName IntrRuleACInfo--instance HasRuleName ProtoRuleE where-  ruleName = ProtoInfo . L.get rInfo--instance HasRuleName RuleAC where-  ruleName = ruleInfo (ProtoInfo . L.get pracName) IntrInfo . L.get rInfo--instance HasRuleName ProtoRuleAC where-  ruleName = ProtoInfo . L.get (pracName . rInfo)--instance HasRuleName IntrRuleAC where-  ruleName = IntrInfo . L.get rInfo--instance HasRuleName RuleACInst where-  ruleName = ruleInfo (ProtoInfo . L.get praciName) IntrInfo . L.get rInfo----- Queries--------------- | True iff the rule is a destruction rule.-isDestrRule :: HasRuleName r => r -> Bool-isDestrRule ru = case ruleName ru of-  IntrInfo (DestrRule _) -> True-  _                      -> False---- | True iff the rule is a construction rule.-isConstrRule :: HasRuleName r => r -> Bool-isConstrRule ru = case ruleName ru of-  IntrInfo (ConstrRule _)  -> True-  IntrInfo FreshConstrRule -> True-  IntrInfo PubConstrRule   -> True-  IntrInfo CoerceRule      -> True-  _                        -> False---- | True iff the rule is the special fresh rule.-isFreshRule :: HasRuleName r => r -> Bool-isFreshRule = (ProtoInfo FreshRule ==) . ruleName---- | True iff the rule is the special learn rule.-isIRecvRule :: HasRuleName r => r -> Bool-isIRecvRule = (IntrInfo IRecvRule ==) . ruleName---- | True iff the rule is the special knows rule.-isISendRule :: HasRuleName r => r -> Bool-isISendRule = (IntrInfo ISendRule ==) . ruleName---- | True iff the rule is the special coerce rule.-isCoerceRule :: HasRuleName r => r -> Bool-isCoerceRule = (IntrInfo CoerceRule ==) . ruleName---- | True if the messages in premises and conclusions are in normal form-nfRule :: Rule i -> WithMaude Bool-nfRule (Rule _ ps cs as) = reader $ \hnd ->-    all (nfFactList hnd) [ps, cs, as]-  where-    nfFactList hnd xs = -        getAll $ foldMap (foldMap (All . (\t -> nf' t `runReader` hnd))) xs---- | True iff the rule is an intruder rule-isIntruderRule :: HasRuleName r => r -> Bool-isIntruderRule ru =-    case ruleName ru of IntrInfo _ -> True; ProtoInfo _ -> False---- | True if the protocol rule has only the trivial variant.-isTrivialProtoVariantAC :: ProtoRuleAC -> ProtoRuleE -> Bool-isTrivialProtoVariantAC (Rule info ps as cs) (Rule _ ps' as' cs') =-    L.get pracVariants info == Disj [emptySubstVFresh]-    && ps == ps' && as == as' && cs == cs'----- Construction------------------type RuleACConstrs = Disj LNSubstVFresh---- | Compute /some/ rule instance of a rule modulo AC. If the rule is a--- protocol rule, then the given typing and variants also need to be handled.-someRuleACInst :: MonadFresh m -               => RuleAC -               -> m (RuleACInst, Maybe RuleACConstrs)-someRuleACInst = -    fmap extractInsts . rename-  where-    extractInsts (Rule (ProtoInfo i) ps cs as) = -      ( Rule (ProtoInfo i') ps cs as-      , Just (L.get pracVariants i)-      )-      where-        i' = ProtoRuleACInstInfo (L.get pracName i) (L.get pracLoopBreakers i)-    extractInsts (Rule (IntrInfo i) ps cs as) = -      ( Rule (IntrInfo i) ps cs as, Nothing )----- Unification------------------- | Unify a list of @RuleACInst@ equalities.-unifyRuleACInstEqs :: [Equal RuleACInst] -> WithMaude [LNSubstVFresh]-unifyRuleACInstEqs eqs -  | all unifiable eqs = unifyLNFactEqs $ concatMap ruleEqs eqs-  | otherwise         = return []-  where-    unifiable (Equal ru1 ru2) = -         L.get rInfo ru1            == L.get rInfo ru2-      && length (L.get rPrems ru1) == length (L.get rPrems ru2)-      && length (L.get rConcs ru1) == length (L.get rConcs ru2)--    ruleEqs (Equal ru1 ru2) = -        zipWith Equal (L.get rPrems ru1) (L.get rPrems ru2) ++ -        zipWith Equal (L.get rConcs ru1) (L.get rConcs ru2)------------------------------------------------------------------------------------- Fact analysis----------------------------------------------------------------------------------- | Globally unique facts.------ A rule instance removes a fact fa if fa is in the rule's premise but not--- in the rule's conclusion.------ A fact symbol fa is globally fresh with respect to a dependency graph if--- there are no two rule instances that remove the same fact built from fa.------ We are looking for sufficient criterion to prove that a fact symbol is--- globally fresh.------ The Fr symbol is globally fresh by construction.------ We have to track every creation of a globally fresh fact to a Fr fact.------ (And show that the equality of of the created fact implies the equality of--- the corresponding fresh facts. Ignore this for now by assuming that no--- duplication happens.)------ (fa(x1), fr(y1)), (fa(x2), fr(y2)) : x2 = x1 ==> y1 == y2------ And ensure that every duplication is non-unifiable.------ A Fr fact is described ------ We track which symbols are not globally fresh.------ All persistent facts are not globally fresh.------ Adding a rule ru.---   All fact symbols that occur twice in the conclusion------ For simplicity: globally fresh fact symbols occur at most once in premise---   and conclusion of a rule.--- --- A fact is removed by a rule if it occurs in the rules premise---   1. but doesn't occur in the rule's conclusion---   2. or does occur but non-unifiable.------ We want a sufficient criterion to prove that a fact is globally unique.----------------------------------------------------------------------------------------- Pretty-Printing----------------------------------------------------------------------------------- | Prefix the name if it is equal to a reserved name.-prefixIfReserved :: String -> String-prefixIfReserved n-  | n `elem` reserved  = "_" ++ n-  | "_" `isPrefixOf` n = "_" ++ n-  | otherwise          = n-  where-    reserved = ["Fresh", "irecv", "isend", "coerce", "fresh", "pub"]--prettyProtoRuleName :: Document d => ProtoRuleName -> d-prettyProtoRuleName rn = text $ case rn of-    FreshRule   -> "Fresh"-    StandRule n -> prefixIfReserved n--prettyRuleName :: (HighlightDocument d, HasRuleName (Rule i)) => Rule i -> d-prettyRuleName = ruleInfo prettyProtoRuleName prettyIntrRuleACInfo . ruleName---- | Pretty print the rule name such that it can be used as a case name-showRuleCaseName :: HasRuleName (Rule i) => Rule i -> String-showRuleCaseName = -    render . ruleInfo prettyProtoRuleName prettyIntrRuleACInfo . ruleName--prettyIntrRuleACInfo :: Document d => IntrRuleACInfo -> d-prettyIntrRuleACInfo rn = text $ case rn of -    IRecvRule       -> "irecv"-    ISendRule       -> "isend"-    CoerceRule      -> "coerce"-    FreshConstrRule -> "fresh"-    PubConstrRule   -> "pub"-    ConstrRule name -> prefixIfReserved ('c' : name)-    DestrRule name  -> prefixIfReserved ('d' : name)--prettyNamedRule :: (HighlightDocument d, HasRuleName (Rule i))-                => d           -- ^ Prefix.-                -> (i -> d)    -- ^ Rule info pretty printing.-                -> Rule i -> d-prettyNamedRule prefix ppInfo ru =-    prefix <-> prettyRuleName ru <> colon $-$-    nest 2 (sep [ nest 1 $ ppFactsList rPrems-                , if null (L.get rActs ru) -                    then operator_ "-->"-                    else fsep [operator_ "--[", ppFacts rActs, operator_ "]->"]-                , nest 1 $ ppFactsList rConcs]) $--$-    nest 2 (ppInfo $ L.get rInfo ru)-  where-    ppList pp        = fsep . punctuate comma . map pp-    ppFacts proj     = ppList prettyLNFact $ L.get proj ru-    ppFactsList proj = fsep [operator_ "[", ppFacts proj, operator_ "]"]--prettyProtoRuleACInfo :: HighlightDocument d => ProtoRuleACInfo -> d-prettyProtoRuleACInfo i =-    (ppVariants $ L.get pracVariants i) $-$-    prettyLoopBreakers i-  where-    ppVariants (Disj [subst]) | subst == emptySubstVFresh = emptyDoc-    ppVariants substs = kwVariantsModulo "AC" $-$ prettyDisjLNSubstsVFresh substs--prettyLoopBreakers :: HighlightDocument d => ProtoRuleACInfo -> d-prettyLoopBreakers i = case breakers of-    []  -> emptyDoc-    [_] -> lineComment_ $ "loop breaker: "  ++ show breakers-    _   -> lineComment_ $ "loop breakers: " ++ show breakers-  where-    breakers = getPremIdx <$> L.get pracLoopBreakers i--prettyProtoRuleE :: HighlightDocument d => ProtoRuleE -> d-prettyProtoRuleE = prettyNamedRule (kwRuleModulo "E") (const emptyDoc)--prettyRuleAC :: HighlightDocument d => RuleAC -> d-prettyRuleAC = -    prettyNamedRule (kwRuleModulo "AC") -        (ruleInfo prettyProtoRuleACInfo (const emptyDoc))--prettyIntrRuleAC :: HighlightDocument d => IntrRuleAC -> d-prettyIntrRuleAC = prettyNamedRule (kwRuleModulo "AC") (const emptyDoc)--prettyProtoRuleAC :: HighlightDocument d => ProtoRuleAC -> d-prettyProtoRuleAC = prettyNamedRule (kwRuleModulo "AC") prettyProtoRuleACInfo--prettyRuleACInst :: HighlightDocument d => RuleACInst -> d-prettyRuleACInst = prettyNamedRule (kwInstanceModulo "AC") (const emptyDoc)---- derived instances-----------------------$( derive makeBinary ''Rule)-$( derive makeBinary ''ProtoRuleName)-$( derive makeBinary ''ProtoRuleACInfo)-$( derive makeBinary ''ProtoRuleACInstInfo)-$( derive makeBinary ''RuleInfo)-$( derive makeBinary ''IntrRuleACInfo)--$( derive makeNFData ''Rule)-$( derive makeNFData ''ProtoRuleName)-$( derive makeNFData ''ProtoRuleACInfo)-$( derive makeNFData ''ProtoRuleACInstInfo)-$( derive makeNFData ''RuleInfo)-$( derive makeNFData ''IntrRuleACInfo)
− src/Theory/RuleSet.hs 
@@ -1,79 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}--- |--- Copyright   : (c) 2012 Simon Meier--- License     : GPL v3 (see LICENSE)--- --- Maintainer  : Simon Meier <iridcode@gmail.com>--- Portability : portable------ Computations over sets of rewriting rules.-module Theory.RuleSet (--  -- * Computing loop breakers for solving premises-  useAutoLoopBreakersAC-  ) where--import Control.Applicative-import Control.Monad.Fresh-import Control.Monad.Reader--import Data.DAG.Simple--import Theory.Rule----- | An over-approximation of the dependency of solving premises. An element--- @((fromRu, fromPrem), (toRu, toPrem))@ denotes that solving the premise--- @(fromRu,fromPrem)@ might lead to a case where the premise @(toRu, toPrem)@--- is open.-premSolvingRelAC :: (a -> [(PremIdx, LNFact)])  -- ^ Enumerate premises-                 -> (a -> [(ConcIdx, LNFact)])  -- ^ Enumerate conclusions-                 -> (a -> [LNSubstVFresh])      -- ^ Enumerate variants-                 -> [a]                         -- ^ Base carrier-                 -> WithMaude (Relation (a, PremIdx))-premSolvingRelAC ePrems eConcs eVariants rules = reader $ \hnd -> do-    (toRu, from) <- dataflowRelAC hnd-    (toPrem, _)  <- ePrems toRu-    return (from, (toRu, toPrem))-  where-    -- An over-approxmiation of the dataflow relation. An element @(fromRu,-    -- (toRu, toPrem))@ denotes that there is a conclusion of @fromRu@-    -- unifying with the premise @(toRu, toPrem)@.-    dataflowRelAC hnd = do-        ruFrom <- rules-        ruTo   <- rules-        (premIdx, premFa0) <- ePrems ruTo-        guard $ or $ do-            premFa <- instances ruTo premFa0-            concFa <- instances ruFrom =<< (snd <$> eConcs ruFrom)-            let concFaFresh = rename concFa `evalFresh` avoid premFa-            return $ (`runReader` hnd) (unifiableLNFacts concFaFresh premFa)-        return (ruFrom, (ruTo, premIdx))--    instances ru fa = do-        subst <- eVariants ru-        return (apply (subst `freshToFreeAvoiding` fa) fa)----- | Replace all loop-breaker information with loop-breakers computed--- automatically from the dataflow relation 'dataflowRelAC'.-useAutoLoopBreakersAC -  :: Ord a-  => (a -> [(PremIdx, LNFact)])  -- ^ Enumerate premises-  -> (a -> [(ConcIdx, LNFact)])  -- ^ Enumerate conclusions-  -> (a -> [LNSubstVFresh])      -- ^ Enumerate variants-  -> ([PremIdx] -> a -> a)       -- ^ Add annotation-  -> [a]                         -- ^ Original rules-  -> WithMaude ([a], Relation (a, PremIdx), [(a, PremIdx)])-  -- ^ Annotated rules and the premise solving relation-useAutoLoopBreakersAC ePrems eConcs eVariants addAnn rules =-    reader $ \hnd ->-      let solveRel = (`runReader` hnd) $-              premSolvingRelAC ePrems eConcs eVariants rules-          breakers = dfsLoopBreakers $ solveRel-      in ( do ru <- rules-              return (addAnn [ u | (ru', u) <- breakers, ru == ru' ] ru)-         , solveRel-         , breakers-         )-
− src/Theory/RuleVariants.hs 
@@ -1,96 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleInstances, StandaloneDeriving #-}-{-# LANGUAGE TypeSynonymInstances, ViewPatterns, ScopedTypeVariables #-}--- |--- Copyright   : (c) 2010-2012 Benedikt Schmidt--- License     : GPL v3 (see LICENSE)--- --- Maintainer  : Benedikt Schmidt <beschmi@gmail.com>--- Portability : GHC only------ Variants of protocol rules.-module Theory.RuleVariants where--import Theory.Rule-import Term.Rewriting.Norm-import Term.Narrowing.Variants-import Theory.Proof.EquationStore--import Extension.Prelude-import Logic.Connectives--import Control.Monad.Reader-import Control.Monad.Bind-import qualified Control.Monad.Trans.PreciseFresh as Precise-import Control.Applicative--import qualified Data.Map as M-import Data.Traversable (traverse)-import qualified Data.Set as S--import Debug.Trace.Ignore---- Variants of protocol rules--------------------------------------------------------------------------- | Compute the variants of a protocol rule.---   1. Abstract away terms in facts with variables.---   2. Compute variants of RHSs of equations.---   3. Apply variant substitutions to equations---      to obtain DNF of equations.---   4. Simplify rule.-variantsProtoRule :: MaudeHandle -> ProtoRuleE -> ProtoRuleAC-variantsProtoRule hnd ru@(Rule ri prems0 concs0 acts0) =-    -- rename rule to decrease variable indices-    (`Precise.evalFresh` Precise.nothingUsed) . renamePrecise  $ convertRule `evalFreshAvoiding` ru-  where-    convertRule = do-        (abstrPsCsAs, bindings) <- abstrRule-        let eqsAbstr         = map swap (M.toList bindings)-            abstractedTerms  = map snd eqsAbstr-            abstractionSubst = substFromList eqsAbstr-            variantSubsts    = computeVariants (fAppList abstractedTerms) `runReader` hnd-            substs           = [ restrictVFresh (frees abstrPsCsAs) $-                                   removeRenamings $ ((`runReader` hnd) . normSubstVFresh')  $-                                   composeVFresh vsubst abstractionSubst-                               | vsubst <- variantSubsts ]--        case substs of-          [] -> error $ "variantsProtoRule: rule has no variants `"++show ru++"'"-          _  -> do-              -- x <- return (emptySubst, Just substs) -- -              x <- simpDisjunction hnd (const False) (Disj substs)-              case trace (show ("SIMP",abstractedTerms,-                                "abstr", abstrPsCsAs,-                                "substs", substs,-                                "simpSubsts:", x)) x of-                -- the variants can be simplified to a single case-                (commonSubst, Nothing) ->-                  return $ makeRule abstrPsCsAs commonSubst trueDisj-                (commonSubst, Just freshSubsts) ->-                  return $ makeRule abstrPsCsAs commonSubst freshSubsts--    abstrRule = (`runBindT` noBindings) $ do-        -- first import all vars into binding to obtain nicer names-        mapM_ abstrTerm [ varTerm v | v <- frees (prems0, concs0, acts0) ]-        (,,) <$> mapM abstrFact prems0-             <*> mapM abstrFact concs0-             <*> mapM abstrFact acts0--    irreducible = irreducibleFunctionSymbols (mhMaudeSig hnd)-    abstrFact = traverse abstrTerm-    abstrTerm (viewTerm -> FApp (NonAC o) args) | o `S.member` irreducible =-        fAppNonAC o <$> mapM abstrTerm args-    abstrTerm t = do-        at :: LNTerm <- varTerm <$> importBinding (`LVar` sortOfLNTerm t) t (getHint t)-        return at-      where getHint (viewTerm -> Lit (Var v)) = lvarName v-            getHint _                         = "z"--    makeRule (ps, cs, as) subst freshSubsts0 =-        Rule (ProtoRuleACInfo ri (Disj freshSubsts) []) prems concs acts-      where prems = apply subst ps-            concs = apply subst cs-            acts  = apply subst as-            freshSubsts = map (restrictVFresh (frees (prems, concs, acts))) freshSubsts0--    trueDisj = [ emptySubstVFresh ]
− src/Theory/Signature.hs 
@@ -1,196 +0,0 @@-{-# LANGUAGE TemplateHaskell, DeriveDataTypeable, DeriveFunctor #-}-{-# LANGUAGE StandaloneDeriving, TypeSynonymInstances #-}-{-# LANGUAGE TypeOperators,FlexibleInstances #-}--- |--- Copyright   : (c) 2010-2012 Benedikt Schmidt & Simon Meier--- License     : GPL v3 (see LICENSE)--- --- Maintainer  : Simon Meier <iridcode@gmail.com>--- Portability : portable------ Signatures for the terms and multiset rewriting rules used to model and--- reason about a security protocol.--- modulo the full Diffie-Hellman equational theory and once modulo AC.-module Theory.Signature (--  -- * Signature type-    Signature(..)-  -  -- ** Pure signatures-  , SignaturePure-  , emptySignaturePure-  , sigpUniqueInsts-  , sigpMaudeSig--  -- ** Using Maude to handle operations relative to a 'Signature'-  , SignatureWithMaude-  , toSignatureWithMaude-  , toSignaturePure-  , sigmUniqueInsts-  , sigmMaudeHandle--  -- ** Pretty-printing-  , prettySignaturePure-  , prettySignatureWithMaude--  ) where--import qualified Data.Set                            as S-import qualified Data.Label                          as L--import           Control.Applicative-import           Control.DeepSeq--import           Theory.Pretty-import           Theory.Fact-import           Term.Maude.Signature--import           Data.Binary--import           System.IO.Unsafe (unsafePerformIO)---- | A theory signature.-data Signature a = Signature-       { _sigUniqueInsts :: S.Set FactTag-         -- ^ Fact symbols that are assumed to have unique instances.-       , _sigMaudeInfo  :: a-       }--$(L.mkLabels [''Signature])------------------------------------------------------------------------------------ Pure Signatures----------------------------------------------------------------------------------- | A 'Signature' without an associated Maude process.-type SignaturePure = Signature MaudeSig---- | Access the globally fresh field.-sigpUniqueInsts :: SignaturePure L.:-> S.Set FactTag-sigpUniqueInsts = sigUniqueInsts---- | Access the maude signature.-sigpMaudeSig:: SignaturePure L.:-> MaudeSig-sigpMaudeSig = sigMaudeInfo---- | The empty pure signature.-emptySignaturePure :: SignaturePure-emptySignaturePure = Signature S.empty minimalMaudeSig---- Instances---------------deriving instance Eq       SignaturePure-deriving instance Ord      SignaturePure-deriving instance Show     SignaturePure--instance Binary SignaturePure where-    put sig = put (L.get sigUniqueInsts sig)-              >> put (L.get sigMaudeInfo sig)-    get     = Signature <$> get <*> get--instance NFData SignaturePure where-  rnf (Signature x y) = rnf x `seq` rnf y----------------------------------------------------------------------------------- Signatures with an attached Maude process----------------------------------------------------------------------------------- | A 'Signature' with an associated, running Maude process.-type SignatureWithMaude = Signature MaudeHandle----- | Access the facts that are declared as globally fresh.-sigmUniqueInsts :: SignatureWithMaude L.:-> S.Set FactTag-sigmUniqueInsts = sigUniqueInsts---- | Access the maude handle in a signature.-sigmMaudeHandle :: SignatureWithMaude L.:-> MaudeHandle-sigmMaudeHandle = sigMaudeInfo---- | Ensure that maude is running and configured with the current signature.-toSignatureWithMaude :: FilePath            -- ^ Path to Maude executable.-                     -> SignaturePure-                     -> IO (SignatureWithMaude)-toSignatureWithMaude maudePath sig = do-    hnd <- startMaude maudePath (L.get sigMaudeInfo sig)-    return $ sig { _sigMaudeInfo = hnd }----- | The pure signature of a 'SignatureWithMaude'.-toSignaturePure :: SignatureWithMaude -> SignaturePure-toSignaturePure sig = sig { _sigMaudeInfo = mhMaudeSig $ L.get sigMaudeInfo sig }--{- TODO: There should be a finalizer in place such that as soon as the-   MaudeHandle is garbage collected, the appropriate command is sent to Maude--  The code below is a crutch and leads to unnecessary complication.-- --- | Stop the maude process. This operation is unsafe, as there still might be--- thunks that rely on the MaudeHandle to refer to a running Maude process.-unsafeStopMaude :: SignatureWithMaude -> IO (SignaturePure)-unsafeStopMaude = error "unsafeStopMaude: implement"---- | Run an IO action with maude running and configured with a specific--- signature. As there must not be any part of the return value that depends--- on unevaluated calls to the Maude process provided to the inner IO action.-unsafeWithMaude :: FilePath      -- ^ Path to Maude executable-                -> SignaturePure -- ^ Signature to use-                -> (SignatureWithMaude -> IO a) -> IO a-unsafeWithMaude maudePath sig  =-    bracket (startMaude maudePath sig) unsafeStopMaude ---}---- Instances---------------instance Eq SignatureWithMaude where-  x == y = toSignaturePure x == toSignaturePure y--instance Ord SignatureWithMaude where-  compare x y = compare (toSignaturePure x) (toSignaturePure y)--instance Show SignatureWithMaude where-  show = show . toSignaturePure--instance Binary SignatureWithMaude where-    put sig@(Signature _ maude) = do-        put (mhFilePath maude)-        put (toSignaturePure sig)-    -- FIXME: reload the right signature-    get = unsafePerformIO <$> (toSignatureWithMaude <$> get <*> get)--instance NFData SignatureWithMaude where-  rnf (Signature x _maude) = rnf x----------------------------------------------------------------------------------- Pretty-printing----------------------------------------------------------------------------------- | Pretty-print a signature with maude.-prettySignaturePure :: HighlightDocument d => SignaturePure -> d-prettySignaturePure sig = foldr ($--$) emptyDoc $ map combine $-       [ ("unique_insts",  ppGFresh $ uniqueInsts) | not $ null uniqueInsts ]-       -- FIXME: Print Maude signature completely, this is only used for-       -- intruder-variants for now.-       ++ [ ("builtin", text "diffie-hellman" ) | enableDH . L.get sigpMaudeSig $ sig ]-  where-    uniqueInsts = S.toList $ L.get sigpUniqueInsts sig-    combine (header, d) = fsep [keyword_ header <> colon, nest 2 d]-    ppGFresh = fsep . punctuate comma . map (text . showFactTagArity)-    --- | Pretty-print a pure signature.-prettySignatureWithMaude :: HighlightDocument d => SignatureWithMaude -> d-prettySignatureWithMaude sig = foldr ($--$) emptyDoc $-    (map combine-        [ ("unique_insts",  ppGFresh $ uniqueInsts) | not $ null uniqueInsts ]-    ) ++-    [ prettyMaudeSig $ mhMaudeSig $ L.get sigmMaudeHandle sig ]-  where-    uniqueInsts = S.toList $ L.get sigmUniqueInsts sig-    combine (header, d) = fsep [keyword_ header <> colon, nest 2 d]-    ppGFresh = fsep . punctuate comma . map (text . showFactTagArity)-
+ src/Theory/Text/Lexer.hs view
@@ -0,0 +1,621 @@+{-# LANGUAGE CPP,MagicHash #-}+{-# LINE 1 "src/Theory/Lexer.x" #-}++{-# OPTIONS_GHC -fno-warn-name-shadowing -fno-warn-unused-matches -fno-warn-unused-binds -fno-warn-missing-signatures -fno-warn-lazy-unlifted-bindings #-}+module Theory.Text.Lexer where+++#if __GLASGOW_HASKELL__ >= 603+#include "ghcconfig.h"+#elif defined(__GLASGOW_HASKELL__)+#include "config.h"+#endif+#if __GLASGOW_HASKELL__ >= 503+import Data.Array+import Data.Char (ord)+import Data.Array.Base (unsafeAt)+#else+import Array+import Char (ord)+#endif+#if __GLASGOW_HASKELL__ >= 503+import GHC.Exts+#else+import GlaExts+#endif+alex_base :: AlexAddr+alex_base = AlexA# "\x01\x00\x00\x00\xd9\x00\x00\x00\x4f\x01\x00\x00\x28\x00\x00\x00\x2c\x00\x00\x00\x2d\x00\x00\x00\x18\x00\x00\x00\x00\x00\x00\x00\x0e\x00\x00\x00\x00\x00\x00\x00\x0f\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x1a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1b\x00\x00\x00\x00\x00\x00\x00\x1c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x01\x00\x00\x6e\x02\x00\x00\x3e\x03\x00\x00\x0e\x04\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\xde\x04\x00\x00\xae\x05\x00\x00\x7e\x06\x00\x00\x4e\x07\x00\x00\x1e\x08\x00\x00\xee\x08\x00\x00\xbe\x09\x00\x00\x21\x00\x00\x00\x00\x00\x00\x00\x8e\x0a\x00\x00\x5e\x0b\x00\x00\x2e\x0c\x00\x00\xfe\x0c\x00\x00\xce\x0d\x00\x00\x9e\x0e\x00\x00\x6e\x0f\x00\x00\x3e\x10\x00\x00\x0e\x11\x00\x00\x22\x00\x00\x00\x00\x00\x00\x00\xc7\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf1\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x00\x00\x00\x00\xde\x11\x00\x00\xae\x12\x00\x00\x7e\x13\x00\x00"#++alex_table :: AlexAddr+alex_table = AlexA# "\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x03\x00\x4a\x00\x3d\x00\x44\x00\x42\x00\x45\x00\x4b\x00\x3c\x00\x08\x00\x35\x00\x46\x00\x50\x00\x34\x00\x4f\x00\x4d\x00\x06\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\xff\xff\xff\xff\x07\x00\x09\x00\x0b\x00\x41\x00\xff\xff\x47\x00\x40\x00\x48\x00\x49\x00\x43\x00\x0f\x00\x0d\x00\x30\x00\x10\x00\x12\x00\x04\x00\x03\x00\x14\x00\x16\x00\x1c\x00\x25\x00\x3a\x00\x00\x00\x53\x00\x52\x00\x54\x00\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x3b\x00\x37\x00\x3f\x00\x4e\x00\xff\xff\x51\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1d\x00\x17\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x00\x4c\x00\x39\x00\x3e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x33\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x0a\x00\x15\x00\x0e\x00\x15\x00\x15\x00\x15\x00\x15\x00\x11\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x15\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x0c\x00\x32\x00\x31\x00\x32\x00\x32\x00\x32\x00\x32\x00\x13\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x32\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x18\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x19\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x1a\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x1b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x1e\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x26\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x00\x00\x57\x00\x57\x00\x1f\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x20\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x21\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x22\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x23\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x00\x00\x57\x00\x27\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x28\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x29\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x00\x00\x57\x00\x57\x00\x2a\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x2b\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x2c\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x2d\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x2e\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x2f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x00\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00\x57\x00"#++alex_check :: AlexAddr+alex_check = AlexA# "\xff\xff\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0a\x00\x0a\x00\x2a\x00\x2a\x00\x2a\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x2a\x00\x29\x00\x7d\x00\x2a\x00\x2a\x00\x2f\x00\x20\x00\x2f\x00\x2a\x00\x2a\x00\x2a\x00\x5c\x00\xff\xff\x3e\x00\x2d\x00\x2d\x00\x2d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x3e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x74\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xd7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf7\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00"#++alex_deflt :: AlexAddr+alex_deflt = AlexA# "\x56\x00\xff\xff\xff\xff\xff\xff\x05\x00\x05\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"#++alex_accept = listArray (0::Int,88) [[],[],[],[(AlexAccSkip)],[(AlexAccSkip)],[(AlexAccSkip)],[(AlexAcc (alex_action_29))],[(AlexAcc (alex_action_2))],[(AlexAcc (alex_action_23))],[(AlexAcc (alex_action_3))],[(AlexAcc (alex_action_10))],[(AlexAcc (alex_action_4))],[(AlexAcc (alex_action_15))],[(AlexAcc (alex_action_5))],[(AlexAcc (alex_action_10))],[(AlexAcc (alex_action_6))],[(AlexAcc (alex_action_7))],[(AlexAcc (alex_action_10))],[(AlexAcc (alex_action_8))],[(AlexAcc (alex_action_15))],[(AlexAcc (alex_action_9))],[(AlexAcc (alex_action_10))],[(AlexAcc (alex_action_11))],[(AlexAcc (alex_action_56))],[(AlexAcc (alex_action_56))],[(AlexAcc (alex_action_56))],[(AlexAcc (alex_action_56))],[],[(AlexAcc (alex_action_12))],[(AlexAcc (alex_action_56))],[(AlexAcc (alex_action_56))],[(AlexAcc (alex_action_56))],[(AlexAcc (alex_action_56))],[(AlexAcc (alex_action_56))],[(AlexAcc (alex_action_56))],[(AlexAcc (alex_action_56))],[],[(AlexAcc (alex_action_13))],[(AlexAcc (alex_action_56))],[(AlexAcc (alex_action_56))],[(AlexAcc (alex_action_56))],[(AlexAcc (alex_action_56))],[(AlexAcc (alex_action_56))],[(AlexAcc (alex_action_56))],[(AlexAcc (alex_action_56))],[(AlexAcc (alex_action_56))],[(AlexAcc (alex_action_56))],[],[(AlexAcc (alex_action_14))],[(AlexAcc (alex_action_15))],[(AlexAcc (alex_action_15))],[(AlexAcc (alex_action_20))],[(AlexAcc (alex_action_22))],[(AlexAcc (alex_action_24))],[(AlexAcc (alex_action_25))],[(AlexAcc (alex_action_26))],[(AlexAcc (alex_action_27))],[(AlexAcc (alex_action_28))],[(AlexAcc (alex_action_30))],[],[(AlexAcc (alex_action_31))],[(AlexAcc (alex_action_32))],[(AlexAcc (alex_action_33))],[(AlexAcc (alex_action_34))],[(AlexAcc (alex_action_35))],[(AlexAcc (alex_action_36))],[(AlexAcc (alex_action_37))],[(AlexAcc (alex_action_38))],[(AlexAcc (alex_action_39))],[(AlexAcc (alex_action_40))],[(AlexAcc (alex_action_41))],[(AlexAcc (alex_action_42))],[(AlexAcc (alex_action_43))],[(AlexAcc (alex_action_44))],[(AlexAcc (alex_action_45))],[(AlexAcc (alex_action_46))],[(AlexAcc (alex_action_47))],[(AlexAcc (alex_action_48))],[(AlexAcc (alex_action_49))],[(AlexAcc (alex_action_50))],[(AlexAcc (alex_action_51))],[(AlexAcc (alex_action_52))],[(AlexAcc (alex_action_53))],[(AlexAcc (alex_action_54))],[],[(AlexAcc (alex_action_55))],[(AlexAcc (alex_action_56))],[(AlexAcc (alex_action_56))],[(AlexAcc (alex_action_56))]]+{-# LINE 84 "src/Theory/Lexer.x" #-}+++-- | Lex a keyword+keyword :: Keyword -> AlexAction Keyword+keyword kw input len = return kw++-- | Wrap a string into a keyword+scanString :: (String -> Keyword) -> AlexAction Keyword+scanString kw (_,_,input) len = return $ kw (take len input)++{-+-- | Scan a string until EOF is encountered.+alexScanTokens :: String -> Either String [Keyword]+alexScanTokens inp = runAlex inp gather+  where+  gather = do+    t <- alexMonadScan+    case trace (show t) t of+      EOF -> return [EOF]+      _   -> (t:) `liftM` gather++-- | Scan a file.+scanFile f = do+   inp <- readFile f+   return $ alexScanTokens inp+-}++-- | Formal text types.+data TextType =+       TextBegin String+     | TextContent String+     | TextEnd+     deriving( Eq, Ord, Show )++-- | Lexable Keywords+data Keyword =+    IDENT String+  | TEXT TextType+  | SQUOTE+  | DQUOTE+  | RIGHTARROW+  | LEFTARROW+  | LONGRIGHTARROW+  | LONGLEFTARROW+  | COMMA+  | DOT+  | COLON+  | QUESTIONMARK+  | BANG+  | AND+  | MID+  | DOLLAR+  | AT+  | SHARP+  | PERCENT+  | LPAREN+  | RPAREN+  | LBRACKET+  | RBRACKET+  | LBRACE+  | RBRACE+  | SLASH+  | BACKSLASH+  | TILDE+  | HAT+  | STAR+  | UNDERSCORE+  | MINUS+  | PLUS+  | EQUAL+  | LESS+  | GREATER+  | EOF+  | FORALL+  | EXISTS+  | LAND+  | LOR+  | LNOT+  | APPROX+  -- dummy keyword to get rid of overlapping pattern matches+  | DUMMY_KEYWORD+  deriving( Eq )++instance Show Keyword where+  show kw = case kw of+      IDENT i -> identifier i+      TEXT t -> txt t+      SQUOTE -> symbol "'"+      DQUOTE -> symbol "\""+      RIGHTARROW -> symbol "->"+      LEFTARROW -> symbol "<-"+      LONGRIGHTARROW -> symbol "-->"+      LONGLEFTARROW -> symbol "<--"+      COMMA -> symbol ","+      DOT -> symbol "."+      COLON -> symbol ":"+      QUESTIONMARK -> symbol "?"+      BANG -> symbol "!"+      AND -> symbol "&"+      MID -> symbol "|"+      DOLLAR -> symbol "$"+      AT -> symbol "@"+      SHARP -> symbol "#"+      PERCENT -> symbol "%"+      LPAREN -> symbol "("+      RPAREN -> symbol ")"+      LBRACKET -> symbol "["+      RBRACKET -> symbol "]"+      LBRACE  -> symbol "{"+      RBRACE -> symbol "}"+      SLASH -> symbol "/"+      BACKSLASH -> symbol "\\"+      TILDE -> symbol "~"+      HAT -> symbol "^"+      STAR -> symbol "*"+      UNDERSCORE -> symbol "_"+      MINUS -> symbol "-"+      PLUS -> symbol "+"+      EQUAL -> symbol "="+      LESS -> symbol "<"+      GREATER -> symbol ">"+      EOF -> "end of file"+      FORALL -> symbol   "∀"+      EXISTS -> symbol   "∃"+      LAND -> symbol     "∧"+      LOR -> symbol      "∨"+      LNOT -> symbol     "¬"+      APPROX -> symbol   "≈"+      DUMMY_KEYWORD -> "DUMMY_KEYWORD (this should not occur!)"+    where+      identifier i        = "identifier `" ++ i ++ "'"+      txt (TextBegin t)   = "start of `" ++ t ++ "'"+      txt (TextContent t) = "text `" ++ t ++ "'"+      txt (TextEnd)       = "start of text"+      symbol s            = "symbol `" ++ s ++ "'"+      keyword s           = "keyword `" ++ s ++ "'"++-- -----------------------------------------------------------------------------+-- Alex wrapper code.+--+-- This code is in the PUBLIC DOMAIN; you may copy it freely and use+-- it for any purpose whatsoever.++-- -----------------------------------------------------------------------------+-- The input type+++type AlexInput = (AlexPosn,     -- current position,+                  Char,         -- previous char+                  String)       -- current input string++alexInputPrevChar :: AlexInput -> Char+alexInputPrevChar (p,c,s) = c++alexGetChar :: AlexInput -> Maybe (Char,AlexInput)+alexGetChar (p,c,[]) = Nothing+alexGetChar (p,_,(c:s))  = let p' = alexMove p c in p' `seq`+                                Just (c, (p', c, s))+++-- -----------------------------------------------------------------------------+-- Token positions++-- `Posn' records the location of a token in the input text.  It has three+-- fields: the address (number of chacaters preceding the token), line number+-- and column of a token within the file. `start_pos' gives the position of the+-- start of the file and `eof_pos' a standard encoding for the end of file.+-- `move_pos' calculates the new position after traversing a given character,+-- assuming the usual eight character tab stops.++data AlexPosn = AlexPn !Int !Int !Int+        deriving (Eq)++instance Show AlexPosn where+  show (AlexPn _ l c) = "line "++show l++" column "++show c++alexStartPos :: AlexPosn+alexStartPos = AlexPn 0 1 1++alexMove :: AlexPosn -> Char -> AlexPosn+alexMove (AlexPn a l c) '\t' = AlexPn (a+1)  l     (((c+7) `div` 8)*8+1)+alexMove (AlexPn a l c) '\n' = AlexPn (a+1) (l+1)   1+alexMove (AlexPn a l c) _    = AlexPn (a+1)  l     (c+1)+++-- -----------------------------------------------------------------------------+-- Default monad+++data AlexState = AlexState {+        alex_pos :: !AlexPosn,  -- position at current input location+        alex_inp :: String,     -- the current input+        alex_chr :: !Char,      -- the character before the input+        alex_scd :: !Int,       -- the current startcode+        alex_ocd :: !Int,       -- the old startcode before the comment started+        alex_cmt :: [String]    -- stack of begin comment identifiers+    }++-- Compile with -funbox-strict-fields for best results!++runAlex :: String -> Alex a -> Either String a+runAlex input (Alex f)+   = case f (AlexState {alex_pos = alexStartPos,+                        alex_inp = input,+                        alex_chr = '\n',+                        alex_scd = 0,+                        alex_ocd = 0,+                        alex_cmt = []+             }) of+       Left msg -> Left msg+       Right ( _, a ) -> Right a++newtype Alex a = Alex { unAlex :: AlexState -> Either String (AlexState, a) }++instance Monad Alex where+  m >>= k  = Alex $ \s -> case unAlex m s of+                                Left msg -> Left msg+                                Right (s',a) -> unAlex (k a) s'+  return a = Alex $ \s -> Right (s,a)++alexGetPos :: Alex AlexPosn+alexGetPos = Alex $ \s@AlexState{alex_pos=pos} -> Right (s, pos)++alexGetInput :: Alex AlexInput+alexGetInput+ = Alex $ \s@AlexState{alex_pos=pos,alex_chr=c,alex_inp=inp} ->+        Right (s, (pos,c,inp))++alexSetInput :: AlexInput -> Alex ()+alexSetInput (pos,c,inp)+ = Alex $ \s -> case s{alex_pos=pos,alex_chr=c,alex_inp=inp} of+                  s@(AlexState{}) -> Right (s, ())++alexError :: String -> Alex a+alexError message = Alex $ \s -> Left $ message ++ " in " ++ show (alex_pos s)++alexGetStartCode :: Alex Int+alexGetStartCode = Alex $ \s@AlexState{alex_scd=sc} -> Right (s, sc)++alexSetStartCode :: Int -> Alex ()+alexSetStartCode sc = Alex $ \s -> Right (s{alex_scd=sc}, ())++alexGetOldStartCode :: Alex Int+alexGetOldStartCode = Alex $ \s@AlexState{alex_ocd=sc} -> Right (s, sc)++alexSetOldStartCode :: Int -> Alex ()+alexSetOldStartCode sc = Alex $ \s -> Right (s{alex_ocd=sc}, ())++alexGetComments :: Alex [String]+alexGetComments = Alex $ \s -> Right (s, alex_cmt s)++alexSetComments :: [String] -> Alex ()+alexSetComments cmt = Alex $ \s -> Right (s{alex_cmt=cmt}, ())++alexMonadScan = do+  inp <- alexGetInput+  sc <- alexGetStartCode+  case alexScan inp sc of+    AlexEOF -> alexEOF+    AlexError inp' -> alexError "lexical error"+    AlexSkip  inp' len -> do+        alexSetInput inp'+        alexMonadScan+    AlexToken inp' len action -> do+        alexSetInput inp'+        action inp len++-- -----------------------------------------------------------------------------+-- Useful token actions++type AlexAction result = AlexInput -> Int -> Alex result++-- just ignore this token and scan another one+skip :: AlexAction Keyword+skip input len = alexMonadScan++-- ignore this token, but set the start code to a new value+begin :: Int -> AlexAction Keyword+begin code input len = do alexSetStartCode code; alexMonadScan++-- | Begin a text starting of the given type.+beginText :: String -> Int -> AlexAction Keyword+beginText ty code _ _ = do+  alexSetStartCode code+  return $ TEXT $ TextBegin ty++-- | End a text.+endText :: Int -> AlexAction Keyword+endText code _ _ = do+  alexSetStartCode code+  return $ TEXT TextEnd++-- | Begin a comment starting with the given sign.+beginComment :: String -> Int -> AlexAction Keyword+beginComment cmtBegin code input len = do+  cmts <- alexGetComments+  alexSetComments $ cmtBegin : cmts+  if null cmts+    then alexGetStartCode >>= alexSetOldStartCode+    else return ()+  alexSetStartCode code+  alexMonadScan++-- | End a comment that started with the given begin comment sign.+endComment :: String -> AlexAction Keyword+endComment cmtBegin input len = do+  cmts <- alexGetComments+  case cmts of+    [] -> alexError $ "comment ended but no beginning '"++cmtBegin++"' marked."+    (cmt:cmts') -> do+      if cmt == cmtBegin+        then do+          alexSetComments cmts'+          if null cmts'+            then alexGetOldStartCode >>= alexSetStartCode+            else return ()+        else return ()+      alexMonadScan++-- perform an action for this token, and set the start code to a new value+-- andBegin :: AlexAction result -> Int -> AlexAction result+(action `andBegin` code) input len = do alexSetStartCode code; action input len++alexEOF :: Alex Keyword+alexEOF = return EOF++++++comment,text :: Int+comment = 1+text = 2+alex_action_2 =  beginComment "(*" comment+alex_action_3 =  beginComment "(*" comment+alex_action_4 =  beginComment "(*" comment+alex_action_5 =  endComment "(*"+alex_action_6 =  beginComment "/*" comment+alex_action_7 =  beginComment "/*" comment+alex_action_8 =  beginComment "/*" comment+alex_action_9 =  endComment "/*"+alex_action_10 =  skip+alex_action_11 =  beginText "text" text+alex_action_12 =  beginText "section" text+alex_action_13 =  beginText "subsection" text+alex_action_14 =  endText 0+alex_action_15 =  scanString (TEXT . TextContent)+alex_action_16 =  keyword FORALL+alex_action_17 =  keyword EXISTS+alex_action_18 =  keyword LAND+alex_action_19 =  keyword LOR+alex_action_20 =  keyword LNOT+alex_action_21 =  keyword APPROX+alex_action_22 =  keyword COMMA+alex_action_23 =  keyword LPAREN+alex_action_24 =  keyword RPAREN+alex_action_25 =  keyword LBRACKET+alex_action_26 =  keyword RBRACKET+alex_action_27 =  keyword LBRACE+alex_action_28 =  keyword RBRACE+alex_action_29 =  keyword SLASH+alex_action_30 =  keyword BACKSLASH+alex_action_31 =  keyword SQUOTE+alex_action_32 =  keyword DQUOTE+alex_action_33 =  keyword TILDE+alex_action_34 =  keyword HAT+alex_action_35 =  keyword EQUAL+alex_action_36 =  keyword COLON+alex_action_37 =  keyword DOLLAR+alex_action_38 =  keyword AT+alex_action_39 =  keyword SHARP+alex_action_40 =  keyword PERCENT+alex_action_41 =  keyword STAR+alex_action_42 =  keyword LESS+alex_action_43 =  keyword GREATER+alex_action_44 =  keyword QUESTIONMARK+alex_action_45 =  keyword BANG+alex_action_46 =  keyword AND+alex_action_47 =  keyword MID+alex_action_48 =  keyword DOT+alex_action_49 =  keyword UNDERSCORE+alex_action_50 =  keyword MINUS+alex_action_51 =  keyword PLUS+alex_action_52 =  keyword RIGHTARROW+alex_action_53 =  keyword LEFTARROW+alex_action_54 =  keyword LONGRIGHTARROW+alex_action_55 =  keyword LONGLEFTARROW+alex_action_56 =  scanString IDENT+{-# LINE 1 "templates/GenericTemplate.hs" #-}+{-# LINE 1 "templates/GenericTemplate.hs" #-}+{-# LINE 1 "<built-in>" #-}+{-# LINE 1 "<command-line>" #-}+{-# LINE 1 "templates/GenericTemplate.hs" #-}+-- -----------------------------------------------------------------------------+-- ALEX TEMPLATE+--+-- This code is in the PUBLIC DOMAIN; you may copy it freely and use+-- it for any purpose whatsoever.++-- -----------------------------------------------------------------------------+-- INTERNALS and main scanner engine++{-# LINE 37 "templates/GenericTemplate.hs" #-}++{-# LINE 47 "templates/GenericTemplate.hs" #-}+++data AlexAddr = AlexA# Addr#++#if __GLASGOW_HASKELL__ < 503+uncheckedShiftL# = shiftL#+#endif++{-# INLINE alexIndexInt16OffAddr #-}+alexIndexInt16OffAddr (AlexA# arr) off =+#ifdef WORDS_BIGENDIAN+  narrow16Int# i+  where+        i    = word2Int# ((high `uncheckedShiftL#` 8#) `or#` low)+        high = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#)))+        low  = int2Word# (ord# (indexCharOffAddr# arr off'))+        off' = off *# 2#+#else+  indexInt16OffAddr# arr off+#endif++++++{-# INLINE alexIndexInt32OffAddr #-}+alexIndexInt32OffAddr (AlexA# arr) off =+#ifdef WORDS_BIGENDIAN+  narrow32Int# i+  where+   i    = word2Int# ((b3 `uncheckedShiftL#` 24#) `or#`+                     (b2 `uncheckedShiftL#` 16#) `or#`+                     (b1 `uncheckedShiftL#` 8#) `or#` b0)+   b3   = int2Word# (ord# (indexCharOffAddr# arr (off' +# 3#)))+   b2   = int2Word# (ord# (indexCharOffAddr# arr (off' +# 2#)))+   b1   = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#)))+   b0   = int2Word# (ord# (indexCharOffAddr# arr off'))+   off' = off *# 4#+#else+  indexInt32OffAddr# arr off+#endif++++++#if __GLASGOW_HASKELL__ < 503+quickIndex arr i = arr ! i+#else+-- GHC >= 503, unsafeAt is available from Data.Array.Base.+quickIndex = unsafeAt+#endif+++++-- -----------------------------------------------------------------------------+-- Main lexing routines++data AlexReturn a+  = AlexEOF+  | AlexError  !AlexInput+  | AlexSkip   !AlexInput !Int+  | AlexToken  !AlexInput !Int a++-- alexScan :: AlexInput -> StartCode -> AlexReturn a+alexScan input (I# (sc))+  = alexScanUser undefined input (I# (sc))++alexScanUser user input (I# (sc))+  = case alex_scan_tkn user input 0# input sc AlexNone of+        (AlexNone, input') ->+                case alexGetChar input of+                        Nothing ->++++                                   AlexEOF+                        Just _ ->++++                                   AlexError input'++        (AlexLastSkip input'' len, _) ->++++                AlexSkip input'' len++        (AlexLastAcc k input''' len, _) ->++++                AlexToken input''' len k+++-- Push the input through the DFA, remembering the most recent accepting+-- state it encountered.++alex_scan_tkn user orig_input len input s last_acc =+  input `seq` -- strict in the input+  let+        new_acc = check_accs (alex_accept `quickIndex` (I# (s)))+  in+  new_acc `seq`+  case alexGetChar input of+     Nothing -> (new_acc, input)+     Just (c, new_input) ->++++        let+                (base) = alexIndexInt32OffAddr alex_base s+                ((I# (ord_c))) = ord c+                (offset) = (base +# ord_c)+                (check)  = alexIndexInt16OffAddr alex_check offset++                (new_s) = if (offset >=# 0#) && (check ==# ord_c)+                          then alexIndexInt16OffAddr alex_table offset+                          else alexIndexInt16OffAddr alex_deflt s+        in+        case new_s of+            -1# -> (new_acc, input)+                -- on an error, we want to keep the input *before* the+                -- character that failed, not after.+            _ -> alex_scan_tkn user orig_input (len +# 1#)+                        new_input new_s new_acc++  where+        check_accs [] = last_acc+        check_accs (AlexAcc a : _) = AlexLastAcc a input (I# (len))+        check_accs (AlexAccSkip : _)  = AlexLastSkip  input (I# (len))+        check_accs (AlexAccPred a predx : rest)+           | predx user orig_input (I# (len)) input+           = AlexLastAcc a input (I# (len))+        check_accs (AlexAccSkipPred predx : rest)+           | predx user orig_input (I# (len)) input+           = AlexLastSkip input (I# (len))+        check_accs (_ : rest) = check_accs rest++data AlexLastAcc a+  = AlexNone+  | AlexLastAcc a !AlexInput !Int+  | AlexLastSkip  !AlexInput !Int++data AlexAcc a user+  = AlexAcc a+  | AlexAccSkip+  | AlexAccPred a (AlexAccPred user)+  | AlexAccSkipPred (AlexAccPred user)++type AlexAccPred user = user -> AlexInput -> Int -> AlexInput -> Bool++-- -----------------------------------------------------------------------------+-- Predicates on a rule++alexAndPred p1 p2 user in1 len in2+  = p1 user in1 len in2 && p2 user in1 len in2++--alexPrevCharIsPred :: Char -> AlexAccPred _+alexPrevCharIs c _ input _ _ = c == alexInputPrevChar input++--alexPrevCharIsOneOfPred :: Array Char Bool -> AlexAccPred _+alexPrevCharIsOneOf arr _ input _ _ = arr ! alexInputPrevChar input++--alexRightContext :: Int -> AlexAccPred _+alexRightContext (I# (sc)) user _ _ input =+     case alex_scan_tkn user input 0# input sc AlexNone of+          (AlexNone, _) -> False+          _ -> True+        -- TODO: there's no need to find the longest+        -- match when checking the right context, just+        -- the first match will do.++-- used by wrappers+iUnbox (I# (i)) = i
+ src/Theory/Text/Parser.hs view
@@ -0,0 +1,842 @@+{-# LANGUAGE TupleSections #-}+-- |+-- Copyright   : (c) 2010-2012 Simon Meier, Benedikt Schmidt+-- License     : GPL v3 (see LICENSE)+--+-- Maintainer  : Simon Meier <iridcode@gmail.com>+-- Portability : portable+--+-- Parsing protocol theories.+module Theory.Text.Parser (+    parseOpenTheory+  , parseOpenTheoryString+  , parseProofMethod+  , parseLemma+  , parseIntruderRulesDH+  ) where++import           Prelude                hiding (id, (.))++import qualified Data.ByteString.Char8  as BC+import           Data.Char              (toUpper, isUpper, isDigit)+import           Data.Foldable          (asum)+import           Data.Label+import qualified Data.Map               as M+import           Data.Monoid+import qualified Data.Set               as S++import           Control.Applicative    hiding (empty, many, optional)+import           Control.Category+import           Control.Monad++import           Text.Parsec            hiding (token, (<|>), string )+import qualified Text.Parsec            as P+import           Text.Parsec.Pos+import           Text.PrettyPrint.Class (render)++import           Term.Substitution+import           Term.SubtermRule+import           Theory+import           Theory.Text.Lexer+                   ( Keyword(..), TextType(..), runAlex, AlexPosn(..)+                   , alexGetPos, alexMonadScan+                   )+++------------------------------------------------------------------------------+-- Specializing Parsec to our needs+------------------------------------------------------------------------------++-- Scanner+----------++-- | The tokens delivered by our Alex based scanner+type Token = (SourcePos, Keyword)++-- | Scan a string using the given filename in the error messages.+--+-- NOTE: Lexical errors are thrown using 'error'.+scanString :: FilePath -> String -> [Token]+scanString filename s =+  case runAlex s gatherUntilEOF of+    Left err  -> error err+    Right kws -> kws+  where+  gatherUntilEOF = do+    AlexPn _ line col <- alexGetPos+    let pos = newPos filename line col+    k <- alexMonadScan+    case k of+      EOF -> return [(pos,EOF)]+      _   -> do kws <- gatherUntilEOF+                return $ (pos,k) : kws++-- Parser+---------++-- | A parser for a stream of tokens.+type Parser a = Parsec [Token] MaudeSig a++-- | Parse a token based on the acceptance condition+token :: (Keyword -> Maybe a) -> Parser a+token p = P.token (show . snd) fst (p . snd)++-- | Parse a term.+kw :: Keyword -> Parser ()+kw t = token check+  where+  check t' | t == t' = Just () | otherwise = Nothing++-- | Parse content between keywords.+betweenKWs :: Keyword -> Keyword -> Parser a -> Parser a+betweenKWs l r = between (kw l) (kw r)++{-+-- | Between braces.+braced :: Parser a -> Parser a+braced = betweenKWs LBRACE RBRACE+-}++-- | Between parentheses.+parens :: Parser a -> Parser a+parens = betweenKWs LPAREN RPAREN++-- | Between single quotes.+singleQuoted :: Parser a -> Parser a+singleQuoted = betweenKWs SQUOTE SQUOTE++-- | Between double quotes.+doubleQuoted :: Parser a -> Parser a+doubleQuoted = betweenKWs DQUOTE DQUOTE++-- | Parse an identifier as a string+identifier :: Parser String+identifier = token extract+  where extract (IDENT name)+         -- don't allow certain reserved words as identifiers+         | not (name `elem` ["in","let","rule"]) = Just name+        extract _                                = Nothing++-- | Parse an identifier as a string+string :: String -> Parser ()+string cs = token extract+  where extract (IDENT name) | cs == name = Just ()+        extract _                         = Nothing++-- | Parse a sequence of fixed strings.+strings :: [String] -> Parser ()+strings = mapM_ string++-- | Parse an integer.+integer :: Parser Int+integer = do i <- identifier+             guard (all isDigit i)+             return (read i)++-- | A comma separated list of elements.+commaSep :: Parser a -> Parser [a]+commaSep = (`sepBy` kw COMMA)++{-+-- | A comma separated non-empty list of elements.+commaSep1 :: Parser a -> Parser [a]+commaSep1 = (`sepBy1` kw COMMA)+-}++-- | Parse a list of items '[' item ',' ... ',' item ']'+list :: Parser a -> Parser [a]+list p = kw LBRACKET *> commaSep p <* kw RBRACKET++-- | A formal comment; i.e., (header, body)+formalComment :: Parser (String, String)+formalComment =+    (,) <$> text begin+        <*> (concat <$> many (text content) <* text end)+  where+    text f = token (\t -> case t of TEXT ty -> f ty; _ -> mzero)+    begin (TextBegin str)     = return str+    begin _                   = mzero+    content (TextContent str) = return str+    content _                 = mzero+    end (TextEnd)             = return ()+    end _                     = mzero+++------------------------------------------------------------------------------+-- Lexing and parsing theory files and proof methods+------------------------------------------------------------------------------++-- | Parser a file.+parseFile :: Parser a -> FilePath -> IO a+parseFile parser f = do+  s <- readFile f+  case runParser parser minimalMaudeSig f (scanString f s) of+    Right p -> return p+    Left err -> error $ show err++-- | Parse a security protocol theory file.+parseOpenTheory :: [String] -- ^ Defined flags+                -> FilePath -> IO OpenTheory+parseOpenTheory flags = parseFile (theory flags)++-- | Parse DH intruder rules.+parseIntruderRulesDH :: FilePath -> IO [IntrRuleAC]+parseIntruderRulesDH = parseFile (setState dhMaudeSig >> many intrRule)++-- | Parse a security protocol theory file.+-- TODO: This function seems to parse a string, not a file from a file path?+parseProofMethod :: FilePath -> Either ParseError ProofMethod+parseProofMethod =+    runParser proofMethod minimalMaudeSig dummySource . scanString dummySource+  where+    dummySource = "<interactive>"++-- | Parse a security protocol theory from a string.+parseOpenTheoryString :: [String]  -- ^ Defined flags.+                      -> String -> Either ParseError OpenTheory+parseOpenTheoryString flags = parseFromString (theory flags)++-- | Parse a lemma for an open theory from a string.+parseLemma :: String -> Either ParseError (Lemma ProofSkeleton)+parseLemma = parseFromString lemma++-- | Run a given parser on a given string.+parseFromString :: Parser a -> String -> Either ParseError a+parseFromString parser =+    runParser parser minimalMaudeSig dummySource . scanString dummySource+  where+    dummySource = "<interactive>"++------------------------------------------------------------------------------+-- Parsing Terms+------------------------------------------------------------------------------+++{-+BNF:  Not completely up to date...++theory      := 'theory' ident 'begin' protocol 'end'+protocol    := rules+rules       := rule | rule rules+intrrule    := ident '[' intrinfo ']' ':' terms '-->' terms+intrinfo    := 'Destr' | 'Constr'+protorule   := ident ':' factList '-->' factList+factList    := '[' [facts] ']'+facts       := fact | fact ',' facts+protoFact   := ident '(' terms ')'+terms       := term | term ',' terms+term        := lit | application | '<' term ',' terms '>'  -- right assoc pairing+application := ident '(' terms ')'+lit        := ident | '\'' ident '\''+ident       := <a-zA-Z> (<a-zA-Z0-9-_)+++// example protocol rule++  Init_1:+    [ Pub(I), Pub(R), Fresh(ni) ]+    -->+    [ Init_1(I,R,ni), Send(encA(pk(R), <I,R,ni>)) ]++// example intruder rule++  Exp [Constr]:+    [ (x^_((x1*x2))), ((x3*x1)*_x4) ]+    -->+    [ (x^(x3*_((x4*x2)))) ]++-}++------------------------------------------------------------------------------+-- Parsing Terms+------------------------------------------------------------------------------++-- | Parse an identifier possibly indexed with a number.+indexedIdentifier :: Parser (String, Integer)+indexedIdentifier = do+    (,) <$> identifier+        <*> option 0 (try (kw DOT *> (fromIntegral <$> integer)))++-- | Parse a logical variable with the given sorts allowed.+sortedLVar :: [LSort] -> Parser LVar+sortedLVar ss =+    asum $ map (try . mkSuffixParser) ss ++ map mkPrefixParser ss+  where+    mkSuffixParser s = do+        (n, i) <- indexedIdentifier+        kw COLON+        string (sortSuffix s)+        return (LVar n s i)++    mkPrefixParser s = do+        case s of+          LSortMsg   -> pure ()+          LSortPub   -> kw DOLLAR+          LSortFresh -> kw TILDE+          LSortNode  -> kw SHARP+          LSortMSet  -> kw PERCENT+        (n, i) <- indexedIdentifier+        return (LVar n s i)++-- | An arbitrary logical variable.+lvar :: Parser LVar+lvar = sortedLVar [minBound..]++-- | Parse a non-node variable.+msgvar :: Parser LVar+msgvar = sortedLVar [LSortFresh, LSortPub, LSortMsg, LSortMSet]++-- | Parse a graph node variable.+nodevar :: Parser NodeId+nodevar = asum+  [ sortedLVar [LSortNode]+  , (\(n, i) -> LVar n LSortNode i) <$> indexedIdentifier ]+  <?> "node"++-- | Parse an lit with logical variables.+llit :: Parser LNTerm+llit = asum+    [ freshTerm  <$> try (kw TILDE *> singleQuoted identifier) <?> "fresh name"+    , pubTerm    <$> singleQuoted identifier                  <?> "public name"+    , varTerm    <$> msgvar+    ]++-- | Lookup the arity of a non-ac symbol. Fails with a sensible error message+-- if the operator is not known.+lookupNonACArity :: String -> Parser Int+lookupNonACArity op = do+    maudeSig <- getState+    case lookup (BC.pack op) (S.toList $ allFunctionSymbols maudeSig) of+        Nothing -> fail $ "unknown operator `" ++ op ++ "'"+        Just k  -> return k++-- | Parse an n-ary operator application for arbitrary n.+naryOpApp :: Ord l => Parser (Term l) -> Parser (Term l)+naryOpApp plit = do+    op <- identifier+    k  <- lookupNonACArity op+    ts <- parens $ if k == 1+                     then return <$> tupleterm plit+                     else sepBy (multterm plit) (kw COMMA)+    let k' = length ts+    when (k /= k') $+        fail $ "operator `" ++ op ++"' has arity " ++ show k +++               ", but here it is used with arity " ++ show k'+    return $ fAppNonAC (BC.pack op, k') ts++-- | Parse a binary operator written as @op{arg1}arg2@.+binaryAlgApp :: Ord l => Parser (Term l) -> Parser (Term l)+binaryAlgApp plit = do+    op <- identifier+    k <- lookupNonACArity op+    arg1 <- kw LBRACE *> tupleterm plit <* kw RBRACE+    arg2 <- term plit+    when (k /= 2) $ fail $+      "only operators of arity 2 can be written using the `op{t1}t2' notation"+    return $ fAppNonAC (BC.pack op, 2) [arg1, arg2]++-- | Parse a term.+term :: Ord l => Parser (Term l) -> Parser (Term l)+term plit = asum+    [ pairing       <?> "pairs"+    , parens (multterm plit)+    , string "1" *> pure fAppOne+    , application <?> "function application"+    , nullaryApp+    , plit+    ]+    <?> "term"+  where+    application = asum $ map (try . ($ plit)) [naryOpApp, binaryAlgApp]+    pairing = kw LESS *> tupleterm plit <* kw GREATER+    nullaryApp = do+      maudeSig <- getState+      asum [ try (string (BC.unpack sym)) *> pure (fApp (NonAC (sym,0)) [])+           | (sym,0) <- S.toList $ allFunctionSymbols maudeSig ]++-- | A left-associative sequence of exponentations.+expterm :: Ord l => Parser (Term l) -> Parser (Term l)+expterm plit = chainl1 (term plit) ((\a b -> fAppExp (a,b)) <$ kw HAT)++-- | A left-associative sequence of multiplications.+multterm :: Ord l => Parser (Term l) -> Parser (Term l)+multterm plit = do+    dh <- enableDH <$> getState+    if dh -- if DH is not enabled, do not accept 'multterm's and 'expterm's+        then chainl1 (expterm plit) ((\a b -> fAppMult [a,b]) <$ kw STAR)+        else term plit++-- | A right-associative sequence of tuples.+tupleterm :: Ord l => Parser (Term l) -> Parser (Term l)+tupleterm plit = chainr1 (multterm plit) ((\a b -> fAppPair (a,b))<$ kw COMMA)++-- | Parse a fact.+fact :: Ord l => Parser (Term l) -> Parser (Fact (Term l))+fact plit =+    do multi <- option Linear (kw BANG *> pure Persistent)+       i     <- identifier+       case i of+         []                -> fail "empty identifier"+         (c:_) | isUpper c -> return ()+               | otherwise -> fail "facts must start with upper-case letters"+       ts    <- parens (sepBy (multterm plit) (kw COMMA))+       mkProtoFact multi i ts+    <?> "protocol fact"+  where+    singleTerm _ constr [t] = return $ constr t+    singleTerm f _      ts  = fail $ "fact '" ++ f ++ "' used with arity " +++                                     show (length ts) ++ " instead of arity one"++    mkProtoFact multi f = case map toUpper f of+      "OUT" -> singleTerm f outFact+      "IN"  -> singleTerm f inFact+      "KU"  -> return . Fact KUFact+      "KD"  -> return . Fact KDFact+      "DED" -> return . Fact DedFact+      "FR"  -> singleTerm f freshFact+      _     -> return . protoFact multi f+++------------------------------------------------------------------------------+-- Parsing Rules+------------------------------------------------------------------------------++-- | Parse a "(modulo ..)" information.+modulo :: String -> Parser ()+modulo thy = parens $ strings ["modulo", thy]++moduloE, moduloAC :: Parser ()+moduloE  = modulo "E"+moduloAC = modulo "AC"++{-+-- | Parse a typing assertion modulo E.+typeAssertions :: Parser TypingE+typeAssertions = fmap TypingE $+    do try (strings ["type", "assertions"])+       optional moduloE+       kw COLON+       many1 ((,) <$> (try (msgvar <* kw COLON))+                  <*> ( commaSep1 (try $ multterm llit) <|>+                        (kw MINUS *> pure [])+                      )+             )+    <|> pure []+-}++-- | Parse a protocol rule. For the special rules 'Reveal_fresh', 'Fresh',+-- 'Knows', and 'Learn' no rule is returned as the default theory already+-- contains them.+protoRule :: Parser (ProtoRuleE)+protoRule = do+    name  <- try (string "rule" *> optional moduloE *> identifier <* kw COLON)+    subst <- option emptySubst letBlock+    (ps,as,cs) <- genericRule+    return $ apply subst $ Rule (StandRule name) ps cs as++-- | Parse a let block with bottom-up application semantics.+letBlock :: Parser LNSubst+letBlock = do+    toSubst <$> (string "let" *> many1 definition <* string "in")+  where+    toSubst = foldr1 compose . map (substFromList . return)+    definition = (,) <$> (sortedLVar [LSortMsg] <* kw EQUAL) <*> multterm llit++-- | Parse an intruder rule.+intrRule :: Parser IntrRuleAC+intrRule = do+    info <- try (string "rule" *> moduloAC *> intrInfo <* kw COLON)+    (ps,as,cs) <- genericRule+    return $ Rule info ps cs as+  where+    intrInfo = do+        name <- identifier+        case name of+          'c':cname -> return $ ConstrRule cname+          'd':dname -> return $ DestrRule dname+          _         -> fail $ "invalid intruder rule name '" ++ name ++ "'"++genericRule :: Parser ([LNFact], [LNFact], [LNFact])+genericRule =+    (,,) <$> list (fact llit)+         <*> ((pure [] <* kw LONGRIGHTARROW) <|>+              (kw MINUS *> kw MINUS *> list (fact llit) <* kw RIGHTARROW))+         <*> list (fact llit)++{-+-- | Add facts to a rule.+addFacts :: String        -- ^ Command to be used: add_concs, add_prems+         -> Parser (String, [LNFact])+addFacts cmd =+    (,) <$> (string cmd *> identifier <* kw COLON) <*> commaSep1 fact+-}++------------------------------------------------------------------------------+-- Parsing transfer notation+------------------------------------------------------------------------------++{-+-- | Parse an lit with strings for both constants as well as variables.+tlit :: Parser TTerm+tlit = asum+    [ constTerm <$> singleQuoted identifier+    , varTerm  <$> identifier+    ]++-- | Parse a single transfer.+transfer :: Parser Transfer+transfer = do+  tf <- (\l -> Transfer l Nothing Nothing) <$> identifier <* kw DOT+  (do right <- kw RIGHTARROW *> identifier <* kw COLON+      desc <- transferDesc+      return $ tf { tfRecv = Just (desc right) }+   <|>+   do right <- kw LEFTARROW *> identifier <* kw COLON+      descr <- transferDesc+      (do left <- try $ identifier <* kw LEFTARROW <* kw COLON+          descl <- transferDesc+          return $ tf { tfSend = Just (descr right)+                      , tfRecv = Just (descl left) }+       <|>+       do return $ tf { tfSend = Just (descr right) }+       )+   <|>+   do left <- identifier+      (do kw RIGHTARROW+          (do right <- identifier <* kw COLON+              desc <- transferDesc+              return $ tf { tfSend = Just (desc left)+                          , tfRecv = Just (desc right) }+           <|>+           do descl <- kw COLON *> transferDesc+              (do right <- kw RIGHTARROW *> identifier <* kw COLON+                  descr <- transferDesc+                  return $ tf { tfSend = Just (descl left)+                              , tfRecv = Just (descr right) }+               <|>+               do return $ tf { tfSend = Just (descl left) }+               )+           )+       <|>+       do kw LEFTARROW+          (do desc <- kw COLON *> transferDesc+              return $ tf { tfRecv = Just (desc left) }+           <|>+           do right <- identifier <* kw COLON+              desc <- transferDesc+              return $ tf { tfSend = Just (desc right)+                          , tfRecv = Just (desc left) }+           )+       )+    )+  where+    transferDesc = do+        ts        <- tupleterm tlit+        moreConcs <- (string "note" *> many1 (try $ fact tlit))+                     <|> pure []+        types     <- typeAssertions+        return $ \a -> TransferDesc a ts moreConcs types+++-- | Parse a protocol in transfer notation+transferProto :: Parser [ProtoRuleE]+transferProto = do+    name <- string "anb" *> kw MINUS *> string "proto" *> identifier+    braced (convTransferProto name <$> abbrevs <*> many1 transfer)+  where+    abbrevs = (string "let" *> many1 abbrev) <|> pure []+    abbrev = (,) <$> try (identifier <* kw EQUAL) <*> multterm tlit++-}++------------------------------------------------------------------------------+-- Parsing Proofs+------------------------------------------------------------------------------++{-+-- | Parse a node premise.+nodePrem :: Parser NodePrem+nodePrem = NodePrem <$> parens ((,) <$> nodevar <*> (kw COMMA *> integer))++-- | Parse a node conclusion.+nodeConc :: Parser NodeConc+nodeConc = NodeConc <$> parens ((,) <$> nodevar <*> (kw COMMA *> integer))+-}+++-- | Parse the @\@@ requires operator.+actionOp :: Parser ()+actionOp = try (kw AT)++-- | Parse the @<@ temporal less operator.+lessOp :: Parser ()+lessOp = try (kw LESS)++-- | Parse the @=@ equal operator.+equalOp :: Parser ()+equalOp = kw APPROX <|> kw EQUAL++{-+-- | Parse the @--|@ deduced before operator.+dedBeforeOp :: Parser ()+dedBeforeOp = try (kw MINUS *> kw MINUS *> kw MID)++-- | Parse the @<@ temporal less operator.+edgeOp :: Parser ()+edgeOp = try (kw GREATER *> kw RIGHTARROW)++-- | Parse the @~~>@ chain operator.+chainOp :: Parser ()+chainOp = kw TILDE *> kw TILDE *> kw TILDE *> kw GREATER+-}++-- | Parse a goal.+goal :: Parser Goal+goal = fail "SM: reimplement goal parsing" {- asum+  [ splitGoal+  , premiseGoal+  , chainGoal+  ]+  where+    premiseGoal = try $ do+        v  <- nodevar+        i  <- brackets integer <* requiresOp+        fa <- fact llit+        return $ PremiseGoal fa (NodePrem (v, i))++    chainGoal = ChainGoal+        <$> (try $ term llit <* kw COLON)+        <*> (Chain <$> (nodeConc <* chainOp) <*> nodePrem)++    splitGoal = do+        split <- (string "splitEqsOn"    *> pure SplitEqs) <|>+                 (string "splitTypingOn" *> pure SplitTyping)+        SplitGoal split <$> parens integer+-}++-- | Parse a proof method.+proofMethod :: Parser ProofMethod+proofMethod = optional (kw BANG) *> asum+  [ string "sorry"         *> pure (Sorry "not yet proven")+  , string "simplify"      *> pure Simplify+  , string "solve"         *> (SolveGoal <$> parens goal)+  , string "contradiction" *> pure (Contradiction Nothing)+  ]++-- | Parse a proof skeleton.+proofSkeleton :: Parser ProofSkeleton+proofSkeleton =+    finalProof <|> interProof+  where+    finalProof = do+        method <- string "by" *> proofMethod+        return (LNode (ProofStep method ()) M.empty)++    interProof = do+        method <- proofMethod+        cases  <- (sepBy oneCase (string "next") <* string "qed") <|>+                  ((return . ("",)) <$> proofSkeleton           )+        return (LNode (ProofStep method ()) (M.fromList cases))++    oneCase = (,) <$> (string "case" *> identifier) <*> proofSkeleton++------------------------------------------------------------------------------+-- Parsing Formulas and Lemmas+------------------------------------------------------------------------------++-- | Parse an atom with possibly bound logical variables.+blatom :: Parser BLAtom+blatom = (fmap (fmapTerm (fmap Free))) <$> asum+  [ flip Action <$> try (fact llit <* actionOp) <*> nodevarTerm      <?> "action"+  , Less        <$> try (nodevarTerm <* lessOp)    <*> nodevarTerm   <?> "less"+  , EqE         <$> try (multterm llit <* equalOp) <*> multterm llit <?> "term equality"+  , EqE         <$>     (nodevarTerm  <* equalOp)  <*> nodevarTerm   <?> "node equality"+  ]+  where+    nodevarTerm = (lit . Var) <$> nodevar+    -- nodePrem = annNode PremIdx+    -- nodeConc = annNode ConcIdx+    -- annNode mkAnn = parens ((,) <$> (nodevarTerm <* kw COMMA)+    --                             <*> (mkAnn <$> integer))++-- | Parse an atom of a formula.+fatom :: Parser (LFormula Name)+fatom = asum+  [ pure lfalse <* string "F"+  , pure ltrue  <* string "T"+  , Ato <$> try blatom+  , quantification+  , parens iff+  ]+  where+    quantification = do+        q <- (pure forall <* (kw FORALL <|> string "All")) <|>+             (pure exists <* (kw EXISTS <|> string "Ex") )+        vs <- many1 lvar <* kw DOT+        f  <- iff+        return $ foldr (hinted q) f vs++    hinted :: ((String, LSort) -> LVar -> a) -> LVar -> a+    hinted f v@(LVar n s _) = f (n,s) v++++-- | Parse a negation.+negation :: Parser (LFormula Name)+negation = ((kw LNOT <|> string "not") *> (Not <$> fatom)) <|> fatom++-- | Parse a left-associative sequence of conjunctions.+conjuncts :: Parser (LFormula Name)+conjuncts = chainl1 negation ((.&&.) <$ (kw LAND <|> kw AND))++-- | Parse a left-associative sequence of disjunctions.+disjuncts :: Parser (LFormula Name)+disjuncts = chainl1 conjuncts ((.||.) <$ (kw LOR <|> kw MID))++-- | An implication.+imp :: Parser (LFormula Name)+imp = do+  lhs <- disjuncts+  asum [ try (kw EQUAL *> kw EQUAL *> kw GREATER) *>+             ((lhs .==>.) <$> imp)+       , pure lhs ]++-- | An logical equivalence.+iff :: Parser (LFormula Name)+iff = do+  lhs <- imp+  asum [ try (kw LESS *> kw EQUAL *> kw GREATER) *>+             ((lhs .<=>.) <$> imp)+       , pure lhs ]++-- | Parse a 'LemmaAttribute'.+lemmaAttribute :: Parser LemmaAttribute+lemmaAttribute = asum+  [ string "typing"        *> pure TypingLemma+  , string "reuse"         *> pure ReuseLemma+  , string "use_induction" *> pure InvariantLemma+  ]++-- | Parse a 'TraceQuantifier'.+traceQuantifier :: Parser TraceQuantifier+traceQuantifier = asum+  [ string "all"    *> kw MINUS *> string "traces" *> pure AllTraces+  , string "exists" *> kw MINUS *> string "trace"  *> pure ExistsTrace+  ]++-- | Parse a lemma.+lemma :: Parser (Lemma ProofSkeleton)+lemma = skeletonLemma <$> (string "lemma" *> optional moduloE *> identifier)+                      <*> (option [] $ list lemmaAttribute)+                      <*> (kw COLON *> option AllTraces traceQuantifier)+                      <*> doubleQuoted iff+                      <*> (proofSkeleton <|> pure (unproven ()))++-- | Builtin signatures.+builtins :: Parser ()+builtins =+    string "builtins" *> kw COLON *> sepBy1 builtinTheory (kw COMMA) *> pure ()+  where+    extendSig msig = modifyState (`mappend` msig)+    builtinTheory = asum+      [ try (string "diffie"     *> kw MINUS *> string "hellman")+          *> extendSig dhMaudeSig+      , try (string "symmetric"  *> kw MINUS *> string "encryption")+          *> extendSig symEncMaudeSig+      , try (string "asymmetric" *> kw MINUS *> string "encryption")+          *> extendSig asymEncMaudeSig+      , try (string "signing")+          *> extendSig signatureMaudeSig+      , string "hashing"+          *> extendSig hashMaudeSig+      ]++functions :: Parser ()+functions =+    string "functions" *> kw COLON *> sepBy1 functionSymbol (kw COMMA) *> pure ()+  where+    functionSymbol = do+        funsym <- (,) <$> (BC.pack <$> identifier) <*> (kw SLASH *> integer)+        sig <- getState+        case lookup (fst funsym) (S.toList $ allFunctionSymbols sig) of+          Just k | k /= snd funsym ->+            fail $ "conflicting arities " +++                   show k ++ " and " ++ show (snd funsym) +++                   " for `" ++ BC.unpack (fst funsym)+          _ -> setState (addFunctionSymbol funsym sig)++equations :: Parser ()+equations =+    string "equations" *> kw COLON *> sepBy1 equation (kw COMMA) *> pure ()+  where+    equation = do+        rrule <- RRule <$> term llit <*> (kw EQUAL *> term llit)+        case rRuleToStRule rrule of+          Just str ->+              modifyState (addStRule str)+          Nothing  ->+              fail $ "Not a subterm rule: " ++ show rrule++------------------------------------------------------------------------------+-- Parsing Theories+------------------------------------------------------------------------------+++-- | Parse a theory.+theory :: [String]   -- ^ Defined flags.+       -> Parser OpenTheory+theory flags0 = do+    string "theory"+    thyId <- identifier+    string "begin"+        *> addItems (S.fromList flags0) (set thyName thyId defaultOpenTheory)+        <* string "end"+  where+    addItems :: S.Set String -> OpenTheory -> Parser OpenTheory+    addItems flags thy = asum+      [ do builtins+           msig <- getState+           addItems flags $ set (sigpMaudeSig . thySignature) msig thy+      , do functions+           msig <- getState+           addItems flags $ set (sigpMaudeSig . thySignature) msig thy+      , do equations+           msig <- getState+           addItems flags $ set (sigpMaudeSig . thySignature) msig thy+--      , do thy' <- foldM liftedAddProtoRule thy =<< transferProto+--           addItems flags thy'+      , do thy' <- liftedAddLemma thy =<< lemma+           addItems flags thy'+      , do ru <- protoRule+           thy' <- liftedAddProtoRule thy ru+           addItems flags thy'+      , do r <- intrRule+           addItems flags (addIntrRuleACs [r] thy)+      , do c <- formalComment+           addItems flags (addFormalComment c thy)+      , do ifdef flags thy+      , do define flags thy+      , do return thy+      ]++    define :: S.Set String -> OpenTheory -> Parser OpenTheory+    define flags thy = do+       flag <- try (kw SHARP *> string "define") *> identifier+       addItems (S.insert flag flags) thy++    ifdef :: S.Set String -> OpenTheory -> Parser OpenTheory+    ifdef flags thy = do+       flag <- try (kw SHARP *> string "ifdef") *> identifier+       thy' <- addItems flags thy+       try (kw SHARP *> string "endif")+       if flag `S.member` flags+         then addItems flags thy'+         else addItems flags thy++    liftedAddProtoRule thy ru = case addProtoRule ru thy of+        Just thy' -> return thy'+        Nothing   -> fail $ "duplicate rule: " ++ render (prettyRuleName ru)++    liftedAddLemma thy l = case addLemma l thy of+        Just thy' -> return thy'+        Nothing   -> fail $ "duplicate lemma: " ++ get lName l
+ src/Theory/Text/Pretty.hs view
@@ -0,0 +1,128 @@+-- |+-- Copyright   : (c) 2011 Simon Meier+-- License     : GPL v3 (see LICENSE)+--+-- Maintainer  : Simon Meier <iridcode@gmail.com>+-- Portability : portable+--+-- General support for pretty printing theories.+module Theory.Text.Pretty (+  -- * General highlighters+    module Text.PrettyPrint.Highlight++  -- * Additional combinators+  , vsep+  , fsepList++  -- * Comments+  , lineComment+  , multiComment++  , lineComment_+  , multiComment_++  -- * Keywords+  , kwTheoryHeader+  , kwEnd+  , kwModulo+  , kwBy+  , kwCase+  , kwNext+  , kwQED++  -- ** Composed forms+  , kwLemmaModulo+  , kwRuleModulo+  , kwInstanceModulo+  , kwVariantsModulo+  , kwTypesModulo++  -- * Operators+  , opProvides+  , opRequires+  , opAction+  , opPath+  , opLess+  , opEqual+  , opDedBefore+  , opEdge++  ) where++import Text.PrettyPrint.Highlight+++------------------------------------------------------------------------------+-- Additional combinators+------------------------------------------------------------------------------++-- | Vertically separate a list of documents by empty lines.+vsep :: Document d => [d] -> d+vsep = foldr ($--$) emptyDoc++-- | Pretty print a list of values as a comma-separated list wrapped in+-- paragraph mode.+fsepList :: Document d => (a -> d) -> [a] -> d+fsepList pp = fsep . punctuate comma . map pp+++------------------------------------------------------------------------------+-- Comments+------------------------------------------------------------------------------++lineComment :: HighlightDocument d => d -> d+lineComment d = comment $ text "//" <-> d++lineComment_ :: HighlightDocument d => String -> d+lineComment_ = lineComment . text++multiComment :: HighlightDocument d => d -> d+multiComment d = comment $ fsep [text "/*", d, text "*/"]++multiComment_ :: HighlightDocument d => [String] -> d+multiComment_ ls = comment $ fsep [text "/*", vcat $ map text ls, text "*/"]++------------------------------------------------------------------------------+-- Keywords+------------------------------------------------------------------------------++kwTheoryHeader :: HighlightDocument d => String -> d+kwTheoryHeader name = keyword_ "theory" <-> text name <-> keyword_ "begin"++kwEnd, kwBy, kwCase, kwNext, kwQED :: HighlightDocument d => d+kwEnd    = keyword_ "end"+kwBy     = keyword_ "by"+kwCase   = keyword_ "case"+kwNext   = keyword_ "next"+kwQED    = keyword_ "qed"++kwModulo :: HighlightDocument d+         => String  -- ^ What+         -> String  -- ^ modulo theory+         -> d+kwModulo what thy = keyword_ what <-> parens (keyword_ "modulo" <-> text thy)++kwLemmaModulo, kwRuleModulo, kwInstanceModulo, kwTypesModulo, kwVariantsModulo+  :: HighlightDocument d => String -> d+kwLemmaModulo    = kwModulo "lemma"+kwRuleModulo     = kwModulo "rule"+kwInstanceModulo = kwModulo "instance"+kwTypesModulo    = kwModulo "type assertions"+kwVariantsModulo = kwModulo "variants"+++------------------------------------------------------------------------------+-- Operators+------------------------------------------------------------------------------++opProvides, opRequires, opAction, opPath, opLess, opEqual, opDedBefore, opEdge+  :: HighlightDocument d => d+opProvides  = operator_ ":>"+opRequires  = operator_ "<:"+opAction    = operator_ "@"+opPath      = operator_ ">+>"+opLess      = operator_ "<"+opEqual     = operator_ "="+opDedBefore = operator_ "--|"+opEdge      = operator_ ">->"+
+ src/Theory/Tools/AbstractInterpretation.hs view
@@ -0,0 +1,147 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ViewPatterns #-}+-- |+-- Copyright   : (c) 2012 Benedikt Schmidt & Simon Meier+-- License     : GPL v3 (see LICENSE)+--+-- Maintainer  : Simon Meier <iridcode@gmail.com>+--+-- Abstract intepretation for partial evaluation of multiset rewriting+-- systems.+module Theory.Tools.AbstractInterpretation (+  -- * Combinator to define abstract interpretations+    interpretAbstractly++  -- ** Actual interpretations+  , EvaluationStyle(..)+  , partialEvaluation++  ) where++import           Debug.Trace++import           Control.Basics+import           Control.Monad.Bind+import           Control.Monad.Reader++import           Data.Label+import           Data.List+import qualified Data.Set             as S+import           Data.Traversable     (traverse)++import           Term.Substitution+import           Theory.Model+import           Theory.Text.Pretty+++------------------------------------------------------------------------------+-- Abstract enough versions of builtin rules for computing+------------------------------------------------------------------------------+++-- | Higher-order combinator to construct abstract interpreters.+interpretAbstractly+    :: (Eq s, HasFrees i, Apply i)+    => ([Equal LNFact] -> [LNSubstVFresh])+    -- ^ Unification  of equalities over facts. We assume that facts with+    -- different tags are never unified.+    -> s                  -- ^ Initial abstract state.+    -> (LNFact -> s -> s) -- ^ Add a fact to the abstract state+    -> (s -> [LNFact])    -- ^ Facts of a state.+    -> [Rule i]+    -- ^ Multiset rewriting rules to apply abstractly.+    -> [(s, [Rule i])]+    -- ^ Sequence of abstract states and refined versions of all given+    -- multiset rewriting rules.+interpretAbstractly unifyFactEqs initState addFact stateFacts rus =+    go st0+  where+    st0 = addFact (freshFact (varTerm (LVar "z" LSortFresh 0))) $+          addFact (inFact (varTerm (LVar "z" LSortMsg   0))) $+          initState++    -- Repeatedly refine all rules and add all their conclusions until the+    -- state doesn't change anymore.+    go st =+        (st, rus') : if st == st' then [] else go st'+      where+        rus' = concatMap refineRule rus+        st'  = foldl' (flip addFact) st $ concatMap (get rConcs) rus'++        -- Refine a rule in the context of an abstract state: for all premise+        -- to state facts combinations, try to solve the corresponding+        -- E-unification problem. If successful, return the rule with the+        -- unifier applied.+        refineRule ru = (`evalFreshT` avoid ru) $ do+            eqs <- forM (get rPrems ru) $ \prem -> msum $ do+                fa <- stateFacts st+                guard (factTag prem == factTag fa)+                -- we compute a list of 'FreshT []' actions for the outer msum+                return (Equal prem <$> rename fa)+            subst <- msum $ freshToFree <$> unifyFactEqs eqs+            return $ apply subst ru++-- | How to report on performing a partial evaluation.+data EvaluationStyle = Silent | Summary | Tracing++-- | Concrete partial evaluator activated with flag: --partial-evaluation+partialEvaluation :: EvaluationStyle+                  -> [ProtoRuleE] -> WithMaude (S.Set LNFact, [ProtoRuleE])+partialEvaluation evalStyle ruEs = reader $ \hnd ->+    consumeEvaluation $ interpretAbstractly+        ((`runReader` hnd) . unifyLNFactEqs)  -- FIXME: Use E-unification here+        S.empty+        (S.insert . absFact)+        S.toList+        ruEs+  where+    consumeEvaluation [] = error "partialEvaluation: impossible"+    consumeEvaluation ((st0, rus0) : rest0) =+        go (0 :: Int) st0 rus0 rest0+      where+        go _ st rus [] =+          ( st+          , nubBy eqModuloFreshnessNoAC $                 -- remove duplicates+            map ((`evalFresh` nothingUsed) . rename) rus+          )+        go i st _   ((st', rus') : rest) =+            withTrace (go (i + 1) st' rus' rest)+          where+            incDesc = " partial evaluation: step " ++ show i ++ " added " +++                      show (S.size st' - S.size st) ++ " facts"+            withTrace = case evalStyle of+              Silent  -> id+              Summary -> trace incDesc+              Tracing -> trace $ incDesc ++ "\n\n" +++                ( render $ nest 2 $ numbered' $ map prettyLNFact $+                  S.toList $ st' `S.difference` st ) ++ "\n"+++    -- NOTE: We should use an abstract state that identifies all variables at+    -- the same position provided they have the same sort.+    absFact :: LNFact -> LNFact+    absFact fa = case fa of+        Fact OutFact _ -> outFact (varTerm (LVar "z" LSortMsg 0))+        Fact tag ts    -> Fact tag $ evalAbstraction $ traverse absTerm ts+      where+        evalAbstraction = (`evalBind` noBindings) . (`evalFreshT` nothingUsed)++        absTerm t = case viewTerm t of+          Lit (Con _)                   -> pure t+          FApp (sym@(NonAC (_f,_k))) ts+                                        -> fApp sym <$> traverse absTerm ts+          -- | "p" `isPrefixOf` f        -> FApp sym <$> traverse absTerm ts+          _                             -> importBinding mkVar t (varName t)+          where+            mkVar name idx        = varTerm (LVar name (sortOfLNTerm t) idx)+            varName (viewTerm -> Lit (Var v)) = lvarName v+            varName _                         = "z"++{- FIXME: Implement++-- | Perform a simple propagation of sorts at the fact level.+propagateSorts :: [ProtoRuleE]+               -> WithMaude (M.Map FactTag [LSort], [ProtoRuleE])+propagateSorts ruEs = reader $ \hnd ->++-}
+ src/Theory/Tools/EquationStore.hs view
@@ -0,0 +1,565 @@+{-# LANGUAGE DeriveDataTypeable         #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE TemplateHaskell            #-}+{-# LANGUAGE TupleSections              #-}+{-# LANGUAGE TypeOperators              #-}+{-# LANGUAGE ViewPatterns               #-}+-- |+-- Copyright   : (c) 2010-2012 Benedikt Schmidt, Simon Meier+-- License     : GPL v3 (see LICENSE)+--+-- Maintainer  : Benedikt Schmidt <beschmi@gmail.com>+-- Portability : GHC only+--+-- Support for reasoning with and about disjunctions of substitutions.+module Theory.Tools.EquationStore (+  -- * Equations+    SplitId(..)++  , EqStore(..)+  , emptyEqStore+  , eqsSubst+  , eqsConj++  -- ** Equalitiy constraint conjunctions+  , falseEqConstrConj++  -- ** Queries+  , eqsIsFalse+++  -- ** Adding equalities+  , addEqs+  , addRuleVariants++  -- ** Case splitting+  , performSplit++  , splits+  , splitSize+  , splitExists++  -- * Simplification+  , simp+  , simpDisjunction++  -- ** Pretty printing+  , prettyEqStore+) where++import           Logic.Connectives+import           Term.Unification+import           Theory.Text.Pretty++import           Control.Monad.Fresh+import           Control.Monad.Reader+import           Extension.Prelude+import           Utils.Misc++import           Debug.Trace.Ignore++import           Control.Basics+import           Control.DeepSeq+import           Control.Monad.State   hiding (get, modify, put)+import qualified Control.Monad.State   as MS++import           Data.Binary+import           Data.DeriveTH+import qualified Data.Foldable         as F+import           Data.List+import           Data.Maybe+import qualified Data.Set              as S+import           Extension.Data.Label  hiding (for, get)+import qualified Extension.Data.Label  as L+import           Extension.Data.Monoid++------------------------------------------------------------------------------+-- Equation Store                                                --+------------------------------------------------------------------------------++-- | Index of disjunction in equation store+newtype SplitId = SplitId { unSplitId :: Integer }+  deriving( Eq, Ord, Show, Enum, Binary, NFData, HasFrees )++-- FIXME: Make comment parse.+--+-- The semantics of an equation store+-- > EqStore sigma_free+-- >         [ [sigma_i1,..,sigma_ik_i] | i <- [1..l] ]+-- where sigma_free = {t1/x1, .., tk/xk} is+-- >    (x1 = t1 /\ .. /\ xk = tk)+-- > /\_{i in [1..l]}+-- >    ([|sigma_i1|] \/ .. \/ [|sigma_ik_1|] \/ [|mtinfo_i|]+-- where @[|{t_1/x_1,..,t_l/x_l}|] = EX vars(t1,..,tl). x_1 = t1 /\ .. /\ x_l = t_l@.+-- Note that the 'LVar's in the range of a substitution are interpreted as+-- fresh variables, i.e., different by construction from the x_i which are+-- free variables.+--+-- The variables in the domain of the substitutions sigma_ij and all+-- variables in sigma_free are free (usually globally existentially quantified).+-- We use Conj [] as a normal form to denote True and Conj [Disj []]+-- as a normal form to denote False.+-- We say a variable @x@ is constrained by a disjunction if there is a substition+-- @s@ in the disjunction with @x `elem` dom s@.+data EqStore = EqStore {+      _eqsSubst       :: LNSubst+    , _eqsConj        :: Conj (SplitId, S.Set LNSubstVFresh)+    , _eqsNextSplitId :: SplitId+    }+  deriving( Eq, Ord )++$(mkLabels [''EqStore])++-- | @emptyEqStore@ is the empty equation store.+emptyEqStore :: EqStore+emptyEqStore = EqStore emptySubst (Conj []) (SplitId 0)++-- | @True@ iff the 'EqStore' is contradictory.+eqsIsFalse :: EqStore -> Bool+eqsIsFalse = any ((S.empty == ) . snd) . getConj . L.get eqsConj++-- | The false conjunction. It is always identified with split number -1.+falseEqConstrConj :: Conj (SplitId, S.Set (LNSubstVFresh))+falseEqConstrConj = Conj [ (SplitId (-1), S.empty) ]+++-- Instances+------------++instance Apply SplitId where+    apply _ = id++instance HasFrees EqStore where+    foldFrees f (EqStore subst substs nextSplitId) =+        foldFrees f subst <> foldFrees f substs <> foldFrees f nextSplitId+    mapFrees f (EqStore subst substs nextSplitId) =+        EqStore <$> mapFrees f subst+                <*> mapFrees f substs+                <*> mapFrees f nextSplitId++++-- Equation Store+----------------------------------------------------------------------++-- | We use the empty set (disjunction) to denote false.+falseDisj :: S.Set LNSubstVFresh+falseDisj = S.empty+++-- Dealing with equations+----------------------------------------------------------------------++-- | Returns the list of all @SplitId@s valid for the given equation store+-- sorted by the size of the disjunctions.+splits :: EqStore -> [SplitId]+splits eqs = map fst $ nub $ sortOn snd+    [ (idx, S.size conj) | (idx, conj) <- getConj $ L.get eqsConj eqs ]++-- | Returns the number of cases for a given 'SplitId'.+splitExists :: EqStore -> SplitId -> Bool+splitExists eqs = isJust . splitSize eqs++-- | Returns the number of cases for a given 'SplitId'.+splitSize :: EqStore -> SplitId -> Maybe Int+splitSize eqs sid =+    (S.size . snd) <$> (find ((sid ==) . fst) $ getConj $ L.get eqsConj $ eqs)++-- | Add a disjunction to the equation store at the beginning+addDisj :: EqStore -> (S.Set LNSubstVFresh) -> (EqStore, SplitId)+addDisj eqStore disj =+    (   modify eqsConj ((Conj [(sid, disj)]) `mappend`)+      $ modify eqsNextSplitId succ+      $ eqStore+    , sid+    )+  where+    sid = L.get eqsNextSplitId eqStore++-- | @performSplit eqs i@ performs a case-split on the first disjunction+-- with the given 'SplitId'.+performSplit :: EqStore -> SplitId -> Maybe [EqStore]+performSplit eqStore idx =+    case break ((idx ==) . fst) (getConj $ L.get eqsConj eqStore) of+        (_, [])                   -> Nothing+        (before, (_, disj):after) -> Just $+            mkNewEqStore before after <$> S.toList disj+  where+    mkNewEqStore before after subst =+        fst $ addDisj (set eqsConj (Conj (before ++ after)) eqStore)+                      (S.singleton subst)++-- | Add a list of term equalities to the equation store. Returns the split+-- identifier of the disjunction in resulting equation store.+addEqs :: MonadFresh m+       => MaudeHandle -> [Equal LNTerm] -> EqStore -> m (EqStore, Maybe SplitId)+addEqs hnd eqs0 eqStore =+    case unifyLNTermFactored eqs `runReader` hnd of+        (_, []) ->+            return (set eqsConj falseEqConstrConj eqStore, Nothing)+        (subst, [substFresh]) | substFresh == emptySubstVFresh ->+            return (applyEqStore hnd subst eqStore, Nothing)+        (subst, substs) -> do+            let (eqStore', sid) = addDisj (applyEqStore hnd subst eqStore)+                                          (S.fromList substs)+            return (eqStore', Just sid)+            {-+            case splitStrat of+                SplitLater ->+                    return [ addDisj (applyEqStore hnd subst eqStore) (S.fromList substs) ]+                SplitNow ->+                    addEqsAC (modify eqsSubst (compose subst) eqStore)+                        <$> simpDisjunction hnd (const False) (Disj substs)+            -}+  where+    eqs = apply (L.get eqsSubst eqStore) $ trace (unlines ["addEqs: ", show eqs0]) $ eqs0+    {-+    addEqsAC eqSt (sfree, Nothing)   = [ applyEqStore hnd sfree eqSt ]+    addEqsAC eqSt (sfree, Just disj) =+      fromMaybe (error "addEqsSplit: impossible, splitAtPos failed")+                (splitAtPos (applyEqStore hnd sfree (addDisj eqSt (S.fromList disj))) 0)+-}++-- | Apply a substitution to an equation store and bring resulting equations into+--   normal form again by using unification.+applyEqStore :: MaudeHandle -> LNSubst -> EqStore -> EqStore+applyEqStore hnd asubst eqStore+    | dom asubst `intersect` varsRange asubst /= [] || trace (show ("applyEqStore", asubst, eqStore)) False+    = error $ "applyEqStore: dom and vrange not disjoint for `"++show asubst++"'"+    | otherwise+    = modify eqsConj (fmap (second (S.fromList . concatMap applyBound  . S.toList))) $+          set eqsSubst newsubst eqStore+  where+    newsubst = asubst `compose` L.get eqsSubst eqStore+    applyBound s = map (restrictVFresh (varsRange newsubst ++ domVFresh s)) $+        (`runReader` hnd) $ unifyLNTerm+          [ Equal (apply newsubst (varTerm lv)) t+          | let slist = substToListVFresh s,+            -- variables in the range are fresh, so we have to rename+            -- them away from all other variables in unification problem+            -- NOTE: these variables never enter the global context+            let ran = renameAvoiding (map snd slist)+                                     (domVFresh s ++ varsRange newsubst),+            (lv,t) <- zip (map fst slist) ran+          ]++{- NOTES for @applyEqStore tau@ to a fresh substitution sigma:+[ FIXME: extend explanation to multiple unifiers ]+Let dom(sigma) = x1,..,xk, vrange(sigma) = y1, .. yl, vrange(tau) = z1,..,zn+Fresh substitution denotes formula+  exists #y1, .., #yl. x1 = t1 /\ .. /\ xk = tk+for variables #yi that do not clash with xi and zi [renameAwayFrom]+and with vars(ti) `subsetOf` [#y1, .. #yl].+We apply tau with vrange(tau) = z1,..,zn to the formula to obtain+  exists ##y1, .., ##yl. tau(x1) = t1 /\ .. /\ tau(xk) = tk+unification then yields a lemma+  forall xi zi #yi.+    tau(x1) = t1 /\ .. /\ tau(xk) = tk+    <-> exists vars(s1,..sm). x1 = .. /\ z1 = .. /\ #y1 = ..+So we have+  exists #y1, .., #yl.+    exists vars(s1,..sm). x1 = .. /\ z1 = .. /\ #y1 = ..+<=>+  exists vars(s1,..sm). x1 = .. /\ z1 = ..+      /\  (exists #y1, .., #yl. #y1 = ..)+<=> [restric]+  exists vars(s1,..sm). x1 = .. /\ z1 = .. /\ True+-}++-- | Add the given rule variants.+addRuleVariants :: Disj LNSubstVFresh -> EqStore -> (EqStore, SplitId)+addRuleVariants (Disj substs) eqStore+    | dom freeSubst `intersect` concatMap domVFresh substs /= []+    = error $ "addRuleVariants: Nonempty intersection between domain of variants and free substitution. "+              ++"This case has not been implemented, add rule variants earlier."+    | otherwise = addDisj eqStore (S.fromList substs)+  where+    freeSubst = L.get eqsSubst eqStore+++{-+-- | Return the set of variables that is constrained by disjunction at give position.+constrainedVarsPos :: EqStore -> Int -> [LVar]+constrainedVarsPos eqStore k+    | k < length conj = frees (conj!!k)+    | otherwise       = []+  where+    conj = getConj . L.get eqsConj $ eqStore+-}++-- Simplifying disjunctions+----------------------------------------------------------------------++-- | Simplify given disjunction via EqStore simplification. Obtains fresh+--   names for variables from the underlying 'MonadFresh'.+simpDisjunction :: MonadFresh m+                => MaudeHandle+                -> (LNSubstVFresh -> Bool)+                -> Disj LNSubstVFresh+                -> m (LNSubst, Maybe [LNSubstVFresh])+simpDisjunction hnd isContr disj0 = do+    eqStore' <- simp hnd isContr eqStore+    return (L.get eqsSubst eqStore', wrap $ L.get eqsConj eqStore')+  where+    eqStore = fst $ addDisj emptyEqStore (S.fromList $ getDisj $ disj0)+    wrap (Conj [])          = Nothing+    wrap (Conj [(_, disj)]) = Just $ S.toList disj+    wrap conj               =+        error ("simplifyDisjunction: imposible, unexpected conjunction `"+               ++ show conj ++ "'")+++-- Simplification+----------------------------------------------------------------------++-- | @simp eqStore@ simplifies the equation store.+simp :: MonadFresh m => MaudeHandle -> (LNSubstVFresh -> Bool) -> EqStore -> m EqStore+simp hnd isContr eqStore =+    execStateT (whileTrue (simp1 hnd isContr))+               (trace (show ("eqStore", eqStore)) eqStore)+++-- | @simp1@ tries to execute one simplification step+--   for the equation store. It returns @True@ if+--   the equation store was modified.+simp1 :: MonadFresh m => MaudeHandle -> (LNSubstVFresh -> Bool) -> StateT EqStore m Bool+simp1 hnd isContr = do+    s <- MS.get+    if eqsIsFalse s+        then return False+        else do+          b1 <- simpMinimize isContr+          b2 <- simpRemoveRenamings+          b3 <- simpEmptyDisj+          b4 <- foreachDisj hnd simpSingleton+          b5 <- foreachDisj hnd simpAbstractSortedVar+          b6 <- foreachDisj hnd simpIdentify+          b7 <- foreachDisj hnd simpAbstractFun+          b8 <- foreachDisj hnd simpAbstractName+          (trace (show ("simp:", [b1, b2, b3, b4, b5, b6, b7, b8]))) $+              return $ (or [b1, b2, b3, b4, b5, b6, b7, b8])+++-- | Remove variable renamings in fresh substitutions.+simpRemoveRenamings :: MonadFresh m => StateT EqStore m Bool+simpRemoveRenamings = do+    conj <- gets (L.get eqsConj)+    if F.any (S.foldl' (\b subst -> b || domVFresh subst /= domVFresh (removeRenamings subst)) False . snd) conj+      then modM eqsConj (fmap (second $ S.map removeRenamings)) >> return True+      else return False+++-- | If empty disjunction is found, the whole conjunct+--   can be simplified to False.+simpEmptyDisj :: MonadFresh m => StateT EqStore m Bool+simpEmptyDisj = do+    conj <- getM eqsConj+    if (F.any ((== falseDisj) . snd) conj && conj /= falseEqConstrConj)+      then eqsConj =: falseEqConstrConj >> return True+      else return False+++-- | If there is a singleton disjunction, it can be+--   composed with the free substitution.+simpSingleton :: MonadFresh m+              => [LNSubstVFresh]+              -> m (Maybe (Maybe LNSubst, [S.Set LNSubstVFresh]))+simpSingleton [subst0] = do+        subst <- freshToFree subst0+        return (Just (Just subst, []))+simpSingleton _        = return Nothing+++-- | If all substitutions @si@ map a variable @v@ to terms with the same+--   outermost function symbol @f@, then they all contain the common factor+--   @{v |-> f(x1,..,xk)}@ for fresh variables xi and we can replace+--   @x |-> ..@ by @{x1 |-> ti1, x2 |-> ti2, ..}@ in all substitutions @si@.+simpAbstractFun :: MonadFresh m+                => [LNSubstVFresh]+                -> m (Maybe (Maybe LNSubst, [S.Set LNSubstVFresh]))+simpAbstractFun []             = return Nothing+simpAbstractFun (subst:others) = case commonOperators of+    [] -> return Nothing+    -- abstract all arguments+    (v, o, argss@(args:_)):_ | all ((==length args) . length) argss -> do+        fvars <- mapM (\_ -> freshLVar "x" LSortMsg) args+        let substs' = zipWith (abstractAll v fvars) (subst:others) argss+            fsubst  = substFromList [(v, fApp o (map varTerm fvars))]+        return $ Just (Just fsubst, [S.fromList substs'])+    -- abstract first two arguments+    (v, o@(AC _), argss):_ -> do+        fv1 <- freshLVar "x" LSortMsg+        fv2 <- freshLVar "x" LSortMsg+        let substs' = zipWith (abstractTwo o v fv1 fv2) (subst:others) argss+            fsubst  = substFromList [(v, fApp o (map varTerm [fv1,fv2]))]+        return $ Just (Just fsubst, [S.fromList substs'])+    (_, _ ,_):_ ->+        error "simpAbstract: impossible, invalid arities or List operator encountered."+  where+    commonOperators = do+        (v, viewTerm -> FApp o args) <- substToListVFresh subst+        let images = map (\s -> imageOfVFresh s v) others+            argss  = [ args' | Just (viewTerm -> FApp o' args') <- images, o' == o ]+        guard (length argss == length others)+        return (v, o, args:argss)++    abstractAll v freshVars s args = substFromListVFresh $+        filter ((/= v) . fst) (substToListVFresh s) ++ zip freshVars args++    abstractTwo o v fv1 fv2 s args = substFromListVFresh $+        filter ((/= v) . fst) (substToListVFresh s) ++ newMappings args+      where+        newMappings []      =+            error "simpAbstract: impossible, AC symbols must have arity >= 2."+        newMappings [a1,a2] = [(fv1, a1), (fv2, a2)]+        -- here we always abstract from left to right and do not+        -- take advantage of the AC property of o+        newMappings (a:as)  = [(fv1, a),  (fv2, fApp o as)]+++-- | If all substitutions @si@ map a variable @v@ to the same name @n@,+--   then they all contain the common factor+--   @{v |-> n}@ and we can remove @{v -> n} from all substitutions @si@+simpAbstractName :: MonadFresh m+                 => [LNSubstVFresh]+                 -> m (Maybe (Maybe LNSubst, [S.Set LNSubstVFresh]))+simpAbstractName []             = return Nothing+simpAbstractName (subst:others) = case commonNames of+    []           -> return Nothing+    (v, c):_     ->+        return $ Just (Just $ substFromList [(v, c)]+                      , [S.fromList (map (\s -> restrictVFresh (delete v (domVFresh s)) s) (subst:others))])+  where+    commonNames = do+        (v, c@(viewTerm -> Lit (Con _))) <- substToListVFresh subst+        let images = map (\s -> imageOfVFresh s v) others+        guard (length images == length [ () | Just c' <- images, c' == c])+        return (v, c)+++-- | If all substitutions @si@ map a variable @v@ to variables @xi@ of the same+--   sort @s@ then they all contain the common factor+--   @{v |-> y}@ for a fresh variable of sort @s@+--   and we can replace @{v -> xi}@ by @{y -> xi} in all substitutions @si@+simpAbstractSortedVar :: MonadFresh m+                      => [LNSubstVFresh]+                      -> m (Maybe (Maybe LNSubst, [S.Set LNSubstVFresh]))+simpAbstractSortedVar []             = return Nothing+simpAbstractSortedVar (subst:others) = case commonSortedVar of+    []            -> return Nothing+    (v, s, lvs):_ -> do+        fv <- freshLVar (lvarName v) s+        return $ Just (Just $ substFromList [(v, varTerm fv)]+                      , [S.fromList (zipWith (replaceMapping v fv) lvs (subst:others))])+  where+    commonSortedVar = do+        (v, (viewTerm -> Lit (Var lx))) <- substToListVFresh subst+        guard (sortCompare (lvarSort v)  (lvarSort lx) == Just GT)+        let images = map (\s -> imageOfVFresh s v) others+            -- FIXME: could be generalized to choose topsort s of all images if s < sortOf v+            --        could also be generalized to terms of a given sort+            goodImages = [ ly | Just (viewTerm -> Lit (Var ly)) <- images, lvarSort lx == lvarSort ly]+        guard (length images == length goodImages)+        return (v, lvarSort lx, (lx:goodImages))+    replaceMapping v fv lv sigma =+        substFromListVFresh $ (filter ((/=v) . fst) $ substToListVFresh sigma) ++ [(fv, varTerm lv)]++-- | If all substitutions @si@ map two variables @x@ and @y@ to identical terms @ti@,+--   then they all contain the common factor @{x |-> y} for a fresh variable @z@+--   and we can remove @{x |-> ti}@ from all @si@.+simpIdentify :: MonadFresh m+             => [LNSubstVFresh]+             -> m (Maybe (Maybe LNSubst, [S.Set LNSubstVFresh]))+simpIdentify []             = return Nothing+simpIdentify (subst:others) = case equalImgPairs of+    []         -> return Nothing+    ((v,v'):_) -> do+        let (vkeep, vremove) = case sortCompare (lvarSort v) (lvarSort v') of+                                 Just GT -> (v', v)+                                 Just _  -> (v, v')+                                 Nothing -> error $ "EquationStore.simpIdentify: impossible, variables with incomparable sorts: "+                                                    ++ show v ++" and "++ show v'+        return $ Just (Just  (substFromList [(vremove, varTerm vkeep)]),+                       [S.fromList (map (removeMappings [vkeep]) (subst:others))])+  where+    equalImgPairs = do+        (v,t)    <- substToListVFresh subst+        (v', t') <- substToListVFresh subst+        guard (t == t' && v < v' && all (agrees_on v v') others)+        return (v,v')+    agrees_on v v' s =+        imageOfVFresh s v == imageOfVFresh s v' && isJust (imageOfVFresh s v)+    removeMappings vs s = restrictVFresh (domVFresh s \\ vs) s+++-- | Simplify by removing substitutions that occur twice in a disjunct.+--   We could generalize this function by using AC-equality or subsumption.+simpMinimize :: MonadFresh m => (LNSubstVFresh -> Bool) -> StateT EqStore m Bool+simpMinimize isContr = do+    conj <- MS.gets (L.get eqsConj)+    if F.any (F.any check . snd) conj+      then MS.modify (set eqsConj (fmap (second minimize) conj)) >> return True+      else return False+  where+    minimize substs+      | emptySubstVFresh `S.member` substs = S.singleton emptySubstVFresh+      | otherwise                          = S.filter (not . isContr) substs++    check subst = subst == emptySubstVFresh || isContr subst+++-- | Traverse disjunctions and execute @f@ until it returns+--   @Just (mfreeSubst, disjs)@.+--   Then the @disjs@ is inserted at the current position, if @mfreeSubst@ is+--   @Just freesubst@, then it is applied to the equation store. @True@ is+--   returned if any modifications took place.+foreachDisj :: MonadFresh m+            => MaudeHandle+            -> ([LNSubstVFresh] -> m (Maybe (Maybe LNSubst, [S.Set LNSubstVFresh])))+            -> StateT EqStore m Bool+foreachDisj hnd f =+    go [] =<< gets (getConj . L.get eqsConj)+  where+    go _     []               = return False+    go lefts ((idx,d):rights) = do+        b <- lift $ f (S.toList d)+        case b of+          Nothing              -> go ((idx,d):lefts) rights+          Just (msubst, disjs) -> do+              eqsConj =: Conj (reverse lefts ++ ((,) idx <$> disjs) ++ rights)+              maybe (return ()) (\s -> MS.modify (applyEqStore hnd s)) msubst+              return True++------------------------------------------------------------------------------+-- Pretty printing+------------------------------------------------------------------------------++-- | Pretty print an 'EqStore'.+prettyEqStore :: HighlightDocument d => EqStore -> d+prettyEqStore eqs@(EqStore subst (Conj disjs) _nextSplitId) = vcat $+  [if eqsIsFalse eqs then text "CONTRADICTORY" else emptyDoc] +++  map combine+    [ ("subst", vcat $ prettySubst (text . show) (text . show) subst)+    , ("conj",  vcat $ map ppDisj disjs)+    ]+  where+    combine (header, d) = fsep [keyword_ header <> colon, nest 2 d]+    ppDisj (idx, substs) =+        text (show (unSplitId idx)) <-> numbered' conjs+      where+        conjs  = map ppConj (S.toList substs)+        ppConj = vcat . map prettyEq . substToListVFresh+        prettyEq (a,b) =+          prettyNTerm (lit (Var a)) $$ nest (6::Int) (opEqual <-> prettyNTerm b)++++-- Derived and delayed instances+--------------------------------++instance Show EqStore where+    show = render . prettyEqStore++$( derive makeBinary ''EqStore)+$( derive makeNFData ''EqStore)
+ src/Theory/Tools/IntruderRules.hs view
@@ -0,0 +1,238 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ViewPatterns     #-}+{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}+  -- spurious warnings for view patterns+-- |+-- Copyright   : (c) 2010-2012 Benedikt Schmidt+-- License     : GPL v3 (see LICENSE)+--+-- Maintainer  : Benedikt Schmidt <beschmi@gmail.com>+-- Portability : GHC only+--+module Theory.Tools.IntruderRules (+    subtermIntruderRules+  , dhIntruderRules+  , specialIntruderRules+--  , xorIntruderRules -- there are no multiset intruder rules+  ) where++import           Control.Basics+import           Control.Monad.Fresh+import           Control.Monad.Reader++import qualified Data.ByteString.Char8           as BC+import           Data.List+import qualified Data.Set                        as S++import           Extension.Data.Label++import           Utils.Misc++import           Term.Maude.Signature+import           Term.Narrowing.Variants.Compute+import           Term.Positions+import           Term.Rewriting.Norm+import           Term.SubtermRule++import           Theory.Model++++-- Variants of intruder deduction rules+----------------------------------------------------------------------+++------------------------------------------------------------------------------+-- Special Intruder rules+------------------------------------------------------------------------------++{-+These are the special intruder that are always included.++rule (modulo AC) coerce:+   [ KD( f_, x ) ] --[ KU( f_, x) ]-> [ KU( f_, x ) ]++rule (modulo AC) pub:+   [ ] --[ KU( f_, $x) ]-> [ KU( f_, $x ) ]++rule (modulo AC) gen_fresh:+   [ Fr( ~x ) ] --[ KU( 'noexp', ~x ) ]-> [ KU( 'noexp', ~x ) ]++rule (modulo AC) isend:+   [ KU( f_, x) ] --[ K(x) ]-> [ In(x) ]++rule (modulo AC) irecv:+   [ Out( x) ] --> [ KD( 'exp', x) ]++-}+specialIntruderRules :: [IntrRuleAC]+specialIntruderRules =+    [ kuRule CoerceRule      [Fact KDFact [f_var, x_var]]   [f_var, x_var]+    , kuRule PubConstrRule   []                             [f_var, x_pub_var]+    , kuRule FreshConstrRule [Fact FreshFact [x_fresh_var]] [f_var, x_fresh_var]+    , Rule ISendRule+          [Fact KUFact [f_var, x_var]]+          [Fact InFact [x_var]]+          [kLogFact x_var]+    , Rule IRecvRule+          [Fact OutFact [x_var]]+          [Fact KDFact [expTagToTerm CanExp, x_var]]+          []+    ]+  where+    kuRule name prems ts = Rule name prems [Fact KUFact ts] [Fact KUFact ts]++    f_var       = varTerm (LVar "f_" LSortMsg   0)+    x_var       = varTerm (LVar "x"  LSortMsg   0)+    x_pub_var   = varTerm (LVar "x"  LSortPub   0)+    x_fresh_var = varTerm (LVar "x"  LSortFresh 0)+++------------------------------------------------------------------------------+-- Subterm Intruder theory+------------------------------------------------------------------------------++destructionRules :: StRule -> [IntrRuleAC]+destructionRules (StRule lhs@(viewTerm -> FApp (NonAC (f,_)) _) (RhsPosition pos)) =+    go [] lhs pos+  where+    rhs = lhs `atPos` pos+    go _      _                       []     = []+    -- term already in premises+    go _      (viewTerm -> FApp _ _)  (_:[]) = []+    go uprems (viewTerm -> FApp _ as) (i:p)  =+        irule ++ go uprems' t' p+      where+        uprems' = uprems++[ t | (j, t) <- zip [0..] as, i /= j ]+        t'      = as!!i+        irule = if (t' /= rhs && rhs `notElem` uprems')+                 then (`evalFresh` avoid ([rhs,t']++uprems')) $ do+                     dfact <- kdFact Nothing t'+                     ufacts <- mapM (kuFact Nothing) uprems'+                     concfact <- kdFact (Just CanExp) rhs+                     return [ Rule (DestrRule (BC.unpack f)) (dfact:ufacts) [concfact] [] ]+                 else []+    go _      (viewTerm -> Lit _)     (_:_)  =+        error "IntruderRules.destructionRules: impossible, position invalid"++destructionRules _ = []++-- | Simple removal of subsumed rules for auto-generated free intruder rules.+minimizeIntruderRules :: [IntrRuleAC] -> [IntrRuleAC]+minimizeIntruderRules rules =+    go [] rules+  where+    go checked [] = reverse checked+    go checked (r@(Rule _ prems concs _):unchecked) = go checked' unchecked+      where+        checked' = if any (\(Rule _ prems' concs' _)+                               -> map dropExpTag concs' == map dropExpTag concs &&+                                  map dropExpTag prems' `subsetOf` map dropExpTag prems)+                          (checked++unchecked)+                   then checked+                   else (r:checked)++-- | @freeIntruderRules rus@ returns the set of intruder rules for+--   the free (not Xor, DH, and MSet) part of the given signature.+subtermIntruderRules :: MaudeSig -> [IntrRuleAC]+subtermIntruderRules maudeSig =+     minimizeIntruderRules $ concatMap destructionRules (S.toList $ stRules maudeSig)+     ++ constructionRules (functionSymbols maudeSig)++constructionRules :: FunSig -> [IntrRuleAC]+constructionRules fSig =+    [ createRule s k | (s,k) <- S.toList fSig ]+  where+    createRule s k = (`evalFresh` nothingUsed) $ do+        vars     <- map varTerm <$> (sequence $ replicate k (freshLVar "x" LSortMsg))+        pfacts   <- mapM (kuFact Nothing) vars+        let m = fApp (NonAC (s,k)) vars+        concfact <- kuFact (Just CanExp) m+        return $ Rule (ConstrRule (BC.unpack s)) pfacts [concfact] [concfact]++dropExpTag :: Fact a -> Fact a+dropExpTag (Fact KUFact [_e,m]) = Fact KUFact [m]+dropExpTag (Fact KDFact [_e,m]) = Fact KDFact [m]+dropExpTag t                    = t++------------------------------------------------------------------------------+-- Diffie-Hellman Intruder Rules+------------------------------------------------------------------------------++dhIntruderRules :: WithMaude [IntrRuleAC]+dhIntruderRules = reader $ \hnd -> minimizeIntruderRules $+    [ expRule ConstrRule kuFact return+    , invRule ConstrRule kuFact return+    ] +++    concatMap (variantsIntruder hnd)+      [ expRule DestrRule kdFact (const [])+      , invRule DestrRule kdFact (const [])+      ]+  where+    expRule mkInfo kudFact mkAction = (`evalFresh` nothingUsed) $ do+        b        <- varTerm <$> freshLVar "x" LSortMsg+        e        <- varTerm <$> freshLVar "x" LSortMsg+        bfact    <- kudFact (Just CanExp) b+        efact    <- kuFact Nothing e+        let conc = fAppExp (b, e)+        concfact <- kudFact (Just CannotExp) conc+        return $ Rule (mkInfo "exp") [bfact, efact] [concfact] (mkAction concfact)++    invRule mkInfo kudFact mkAction = (`evalFresh` nothingUsed) $ do+        x        <- varTerm <$> freshLVar "x" LSortMsg+        bfact    <- kudFact Nothing x+        let conc = fAppInv x+        concfact <- kudFact (Just CanExp) conc+        return $ Rule (mkInfo "inv") [bfact] [concfact] (mkAction concfact)+++variantsIntruder :: MaudeHandle -> IntrRuleAC -> [IntrRuleAC]+variantsIntruder hnd ru = do+    let concTerms = concatMap factTerms+                              (get rPrems ru++get rConcs ru++get rActs ru)+    fsigma <- computeVariants (fAppList concTerms) `runReader` hnd+    let sigma     = freshToFree fsigma `evalFreshAvoiding` concTerms+        ruvariant = normRule' (apply sigma ru) `runReader` hnd+    guard (frees (get rConcs ruvariant) /= [] &&+           -- ground terms are already deducible by applying construction rules+           ruvariant /= ru &&+           -- this is a construction rule+           (map dropExpTag (get rConcs ruvariant))+           \\ (map dropExpTag (get rPrems ruvariant)) /= []+           -- The conclusion is included in the premises+           )++    case concatMap factTerms $ get rConcs ruvariant of+        [_, viewTerm -> FApp (AC Mult) _] ->+            fail "Rules with product conclusion are redundant"+        _                     -> return ruvariant+++normRule' :: IntrRuleAC -> WithMaude IntrRuleAC+normRule' (Rule i ps cs as) = reader $ \hnd ->+    let normFactTerms = map (fmap (\t -> norm' t `runReader` hnd)) in+    Rule i (normFactTerms ps) (normFactTerms cs) (normFactTerms as)++++{-+------------------------------------------------------------------------------+-- Xor Intruder Rules+------------------------------------------------------------------------------++xorIntruderRules :: WithMaude [IntrRuleAC]+xorIntruderRules = return []+  -- TODO: extend XOR tagging++maude :: IO MaudeHandle+maude = startMaude "maude" allMaudeSig++t :: IO ()+t = do+  m <- maude+  let rules = dhIntruderRules `runReader` m+  mapM_ (putStrLn . render . prettyIntrRuleAC) rules+  writeFile "/tmp/dhrules" $ unlines (map ((++"\n"). render . prettyIntrRuleAC) rules)+  putStrLn ("\nThere are " ++ show (length rules)+            ++ " and " ++ show (length rules - 3) ++ " of these are exp-down rules")+-}
+ src/Theory/Tools/LoopBreakers.hs view
@@ -0,0 +1,80 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+-- |+-- Copyright   : (c) 2012 Simon Meier+-- License     : GPL v3 (see LICENSE)+--+-- Maintainer  : Simon Meier <iridcode@gmail.com>+-- Portability : portable+--+-- Computate the loop-breakers in the premise-conclusion graph of a set of+-- multiset rewriting rules.+module Theory.Tools.LoopBreakers (++  -- * Computing loop breakers for solving premises+  useAutoLoopBreakersAC+  ) where++import Control.Applicative+import Control.Monad.Fresh+import Control.Monad.Reader++import Data.DAG.Simple++import Theory.Model+++-- | An over-approximation of the dependency of solving premises. An element+-- @((fromRu, fromPrem), (toRu, toPrem))@ denotes that solving the premise+-- @(fromRu,fromPrem)@ might lead to a case where the premise @(toRu, toPrem)@+-- is open.+premSolvingRelAC :: (a -> [(PremIdx, LNFact)])  -- ^ Enumerate premises+                 -> (a -> [(ConcIdx, LNFact)])  -- ^ Enumerate conclusions+                 -> (a -> [LNSubstVFresh])      -- ^ Enumerate variants+                 -> [a]                         -- ^ Base carrier+                 -> WithMaude (Relation (a, PremIdx))+premSolvingRelAC ePrems eConcs eVariants rules = reader $ \hnd -> do+    (toRu, from) <- dataflowRelAC hnd+    (toPrem, _)  <- ePrems toRu+    return (from, (toRu, toPrem))+  where+    -- An over-approxmiation of the dataflow relation. An element @(fromRu,+    -- (toRu, toPrem))@ denotes that there is a conclusion of @fromRu@+    -- unifying with the premise @(toRu, toPrem)@.+    dataflowRelAC hnd = do+        ruFrom <- rules+        ruTo   <- rules+        (premIdx, premFa0) <- ePrems ruTo+        guard $ or $ do+            premFa <- instances ruTo premFa0+            concFa <- instances ruFrom =<< (snd <$> eConcs ruFrom)+            let concFaFresh = rename concFa `evalFresh` avoid premFa+            return $ (`runReader` hnd) (unifiableLNFacts concFaFresh premFa)+        return (ruFrom, (ruTo, premIdx))++    instances ru fa = do+        subst <- eVariants ru+        return (apply (subst `freshToFreeAvoiding` fa) fa)+++-- | Replace all loop-breaker information with loop-breakers computed+-- automatically from the dataflow relation 'dataflowRelAC'.+useAutoLoopBreakersAC+  :: Ord a+  => (a -> [(PremIdx, LNFact)])  -- ^ Enumerate premises+  -> (a -> [(ConcIdx, LNFact)])  -- ^ Enumerate conclusions+  -> (a -> [LNSubstVFresh])      -- ^ Enumerate variants+  -> ([PremIdx] -> a -> a)       -- ^ Add annotation+  -> [a]                         -- ^ Original rules+  -> WithMaude ([a], Relation (a, PremIdx), [(a, PremIdx)])+  -- ^ Annotated rules and the premise solving relation+useAutoLoopBreakersAC ePrems eConcs eVariants addAnn rules =+    reader $ \hnd ->+      let solveRel = (`runReader` hnd) $+              premSolvingRelAC ePrems eConcs eVariants rules+          breakers = dfsLoopBreakers $ solveRel+      in ( do ru <- rules+              return (addAnn [ u | (ru', u) <- breakers, ru == ru' ] ru)+         , solveRel+         , breakers+         )+
+ src/Theory/Tools/RuleVariants.hs view
@@ -0,0 +1,100 @@+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE StandaloneDeriving         #-}+{-# LANGUAGE TypeSynonymInstances       #-}+{-# LANGUAGE ViewPatterns               #-}+-- |+-- Copyright   : (c) 2010-2012 Benedikt Schmidt+-- License     : GPL v3 (see LICENSE)+--+-- Maintainer  : Benedikt Schmidt <beschmi@gmail.com>+-- Portability : GHC only+--+-- Variants of protocol rules.+module Theory.Tools.RuleVariants where++import           Term.Narrowing.Variants+import           Term.Rewriting.Norm+import           Theory.Model+import           Theory.Tools.EquationStore++import           Extension.Prelude+import           Logic.Connectives++import           Control.Applicative+import           Control.Monad.Bind+import           Control.Monad.Reader+import qualified Control.Monad.Trans.PreciseFresh as Precise++import qualified Data.Map                         as M+import qualified Data.Set                         as S+import           Data.Traversable                 (traverse)++import           Debug.Trace.Ignore++-- Variants of protocol rules+----------------------------------------------------------------------++-- | Compute the variants of a protocol rule.+--   1. Abstract away terms in facts with variables.+--   2. Compute variants of RHSs of equations.+--   3. Apply variant substitutions to equations+--      to obtain DNF of equations.+--   4. Simplify rule.+variantsProtoRule :: MaudeHandle -> ProtoRuleE -> ProtoRuleAC+variantsProtoRule hnd ru@(Rule ri prems0 concs0 acts0) =+    -- rename rule to decrease variable indices+    (`Precise.evalFresh` Precise.nothingUsed) . renamePrecise  $ convertRule `evalFreshAvoiding` ru+  where+    convertRule = do+        (abstrPsCsAs, bindings) <- abstrRule+        let eqsAbstr         = map swap (M.toList bindings)+            abstractedTerms  = map snd eqsAbstr+            abstractionSubst = substFromList eqsAbstr+            variantSubsts    = computeVariants (fAppList abstractedTerms) `runReader` hnd+            substs           = [ restrictVFresh (frees abstrPsCsAs) $+                                   removeRenamings $ ((`runReader` hnd) . normSubstVFresh')  $+                                   composeVFresh vsubst abstractionSubst+                               | vsubst <- variantSubsts ]++        case substs of+          [] -> error $ "variantsProtoRule: rule has no variants `"++show ru++"'"+          _  -> do+              -- x <- return (emptySubst, Just substs) --+              x <- simpDisjunction hnd (const False) (Disj substs)+              case trace (show ("SIMP",abstractedTerms,+                                "abstr", abstrPsCsAs,+                                "substs", substs,+                                "simpSubsts:", x)) x of+                -- the variants can be simplified to a single case+                (commonSubst, Nothing) ->+                  return $ makeRule abstrPsCsAs commonSubst trueDisj+                (commonSubst, Just freshSubsts) ->+                  return $ makeRule abstrPsCsAs commonSubst freshSubsts++    abstrRule = (`runBindT` noBindings) $ do+        -- first import all vars into binding to obtain nicer names+        mapM_ abstrTerm [ varTerm v | v <- frees (prems0, concs0, acts0) ]+        (,,) <$> mapM abstrFact prems0+             <*> mapM abstrFact concs0+             <*> mapM abstrFact acts0++    irreducible = irreducibleFunctionSymbols (mhMaudeSig hnd)+    abstrFact = traverse abstrTerm+    abstrTerm (viewTerm -> FApp (NonAC o) args) | o `S.member` irreducible =+        fAppNonAC o <$> mapM abstrTerm args+    abstrTerm t = do+        at :: LNTerm <- varTerm <$> importBinding (`LVar` sortOfLNTerm t) t (getHint t)+        return at+      where getHint (viewTerm -> Lit (Var v)) = lvarName v+            getHint _                         = "z"++    makeRule (ps, cs, as) subst freshSubsts0 =+        Rule (ProtoRuleACInfo ri (Disj freshSubsts) []) prems concs acts+      where prems = apply subst ps+            concs = apply subst cs+            acts  = apply subst as+            freshSubsts = map (restrictVFresh (frees (prems, concs, acts))) freshSubsts0++    trueDisj = [ emptySubstVFresh ]
+ src/Theory/Tools/UniqueFactInstances.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+-- |+-- Copyright   : (c) 2012 Simon Meier+-- License     : GPL v3 (see LICENSE)+--+-- Maintainer  : Simon Meier <iridcode@gmail.com>+-- Portability : portable+--+-- Computate an under-approximation to the set of all facts with unique+-- instances, i.e., fact whose instances never occur more than once in a+-- state. We use this information to reason about protocols that exploit+-- exclusivity of linear facts.+module Theory.Tools.UniqueFactInstances (++  -- * Computing unique fact instances.+  simpleUniqueFactInstances+  ) where++import           Extension.Prelude   (sortednub)++import           Control.Applicative+import           Control.Monad.Fresh+import           Data.Label+import qualified Data.Set            as S++import           Theory.Model++-- | Compute a simple under-approximation to the set of facts with uniqe+-- instances. A fact-tag is guaranteed to have uniqe instances, if it never+-- occurs twice in the conclusions of a rule and each of its occurrences in+-- the conclusion of a rule is guarded by an equal premise or a Fr-fact+-- generating one of the terms used in the fact that we are analyzing.+--+-- We exclude facts that are not copied in a rule, as they are already handled+-- properly by the naive backwards reasoning.+simpleUniqueFactInstances :: [ProtoRuleE] -> S.Set FactTag+simpleUniqueFactInstances rules = S.fromList $ do+    tag <- candidates+    guard (all (guardedSingletonCopy tag) rules)+    return tag+  where+    candidates = sortednub $ do+        ru <- rules+        filter (`elem` (factTag <$> get rPrems ru)) (factTag <$> get rConcs ru)++    guardedSingletonCopy tag ru = and $ do+        copy <- filter ((tag ==) . factTag) (get rConcs ru)+        return $+             (length copies <= 1)+          && (    (copy `elem` get rPrems ru)+               || any (\t -> freshFact t `elem` get rPrems ru) (factTerms copy)+             )+      where+        copies = filter ((tag ==) . factTag) (get rConcs ru)
+ src/Theory/Tools/Wellformedness.hs view
@@ -0,0 +1,496 @@+{-# LANGUAGE ViewPatterns #-}+-- |+-- Copyright   : (c) 2010-2012 Simon Meier & Benedikt Schmidt+-- License     : GPL v3 (see LICENSE)+--+-- Maintainer  : Simon Meier <iridcode@gmail.com>+-- Portability : GHC only+--+-- Wellformedness checks for intruder variants, protocol rules, and+-- properties.+--+-- The following checks are/should be performed+-- (FIXME: compare the list below to what is really implemented.)+--+--   [protocol rules]+--+--     1. no fresh names in rule. (protocol cond. 1)+--     ==> freshNamesReport+--+--     2. no Out or K facts in premises. (protocol cond. 2)+--     ==> factReports+--+--     3. no Fr, In, or K facts in conclusions. (protocol cond. 3)+--     ==> factReports+--+--     4. vars(rhs) subset of vars(lhs) u V_Pub+--     ==> multRestrictedReport+--+--     5. lhs does not contain reducible function symbols (*-restricted (a))+--     ==> multRestrictedReport+--+--     6. rhs does not contain * (*-restricted (b))+--     ==> multRestrictedReport+--+--     7. all facts are used with the same arity.+--+--     8. fr, in, and out, facts are used with arity 1.+--+--     9. fr facts are used with a variable of sort msg or sort fresh+--+--     10. fresh facts of the same rule contain different variables. [TODO]+--+--     11. no protocol fact uses a reserved name =>+--        [TODO] change parser to ensure this and pretty printer to show this.+--+--   [security properties]+--+--     1. all facts occur with the same arity in the action of some+--        protocol rule.+--+--     2. no node variable is used in a message position and vice versa.+--+--+module Theory.Tools.Wellformedness (++  -- * Wellformedness checking+    WfErrorReport+  , checkWellformedness+  , noteWellformedness++  , prettyWfErrorReport+  ) where++import           Prelude                     hiding (id, (.))++import           Control.Basics+import           Control.Category+import           Data.Char+import           Data.Generics.Uniplate.Data (universeBi)+import           Data.Label+import           Data.List+import           Data.Maybe+import           Data.Monoid                 (mappend, mempty)+import qualified Data.Set                    as S+import           Data.Traversable            (traverse)++import           Control.Monad.Bind++import           Extension.Prelude+import           Term.LTerm+import           Term.Maude.Signature+import           Text.PrettyPrint.Class+import           Theory++------------------------------------------------------------------------------+-- Types for error reports+------------------------------------------------------------------------------++type Topic         = String+type WfError       = (Topic, Doc)+type WfErrorReport = [WfError]++prettyWfErrorReport :: WfErrorReport -> Doc+prettyWfErrorReport []     = text "All well-formedness checks were successful."+prettyWfErrorReport report = foldr1 ($-$)+  [ text "Error: the following well-formedness checks failed!"+  , text ""+  , vcat . intersperse (text "") . map ppTopic $ groupOn fst report+  ]+  where+    ppTopic []                 = error "prettyWfErrorReport: groupOn returned empty list"+    ppTopic errs@((topic,_):_) =+      text topic <> colon $-$+      (nest 2 . vcat . intersperse (text "") $ map snd errs)+++------------------------------------------------------------------------------+-- Utilities+------------------------------------------------------------------------------++-- | All protocol rules of a theory.+-- thyProtoRules :: OpenTheory ->+thyProtoRules :: OpenTheory -> [ProtoRuleE]+thyProtoRules thy = [ ru | RuleItem ru <- get thyItems thy ]++-- | Lower-case a string.+lowerCase :: String -> String+lowerCase = map toLower++-- | Pretty-print a comma, separated list of 'LVar's.+prettyVarList :: Document d => [LVar] -> d+prettyVarList = fsep . punctuate comma . map prettyLVar++-- | Pretty-print a comma, separated list of 'LNTerms's.+prettyLNTermList :: Document d => [LNTerm] -> d+prettyLNTermList = fsep . punctuate comma . map prettyLNTerm++-- | Wrap strings at word boundaries.+wrappedText :: Document d => String -> d+wrappedText = fsep . map text . words++-- | Clashes+clashesOn :: (Ord b, Ord c)+          => (a -> b) -- ^ This projection+          -> (a -> c) -- ^ must determine this projection.+          -> [a] -> [[a]]+clashesOn f g xs = do+    grp <- groupOn f $ sortOn f xs+    guard (length (sortednubOn g grp) >= 2)+    return grp++-- | Nice quoting.+quote :: String -> String+quote cs = '`' : cs ++ "'"++------------------------------------------------------------------------------+-- Checks+------------------------------------------------------------------------------++--- | Check that the protocol rules are well-formed.+sortsClashCheck :: HasFrees t => String -> t -> WfErrorReport+sortsClashCheck info t = case clashesOn removeSort id $ frees t of+    [] -> []+    cs -> return $+            ( "sorts"+            , text info $-$ (nest 2 $ numbered' $ map prettyVarList cs)+            )+  where+    removeSort lv = (lowerCase (lvarName lv), lvarIdx lv)++-- | Report on sort clashes.+ruleSortsReport :: OpenTheory -> WfErrorReport+ruleSortsReport thy = do+    ru <- thyProtoRules thy+    sortsClashCheck ("rule " ++ quote (showRuleCaseName ru) +++                     " clashing sorts, casings, or multiplicities:") ru++-- | Report on fresh names.+freshNamesReport :: OpenTheory -> WfErrorReport+freshNamesReport thy = do+    ru <- thyProtoRules thy+    case filter ((LSortFresh ==) . sortOfName) $ universeBi ru of+      []    -> []+      names -> return $ (,) "fresh names" $ fsep $+          text ( "rule " ++ quote (showRuleCaseName ru) ++ ": " +++                 "fresh names are not allowed in rule:" )+        : punctuate comma (map (nest 2 . text . show) names)++-- | Report on capitalization of public names.+publicNamesReport :: OpenTheory -> WfErrorReport+publicNamesReport thy =+    case findClashes publicNames of+      []      -> []+      clashes -> return $ (,) topic $ numbered' $+          map (nest 2 . fsep . punctuate comma . map ppRuleAndName) clashes+  where+    topic       = "public names with mismatching capitalization"+    publicNames = do+        ru <- thyProtoRules thy+        (,) (showRuleCaseName ru) <$>+            (filter ((LSortPub ==) . sortOfName) $ universeBi ru)+    findClashes   = clashesOn (map toLower . show . snd) (show . snd)+    ppRuleAndName (ruName, pub) =+        text $ "rule " ++ show ruName ++ " name " ++ show pub++-- | Check whether a rule has unbound variables.+unboundCheck :: HasFrees i => String -> Rule i -> WfErrorReport+unboundCheck info ru+    | null unboundVars = []+    | otherwise        = return $+        ( "unbound"+        , text info $-$ (nest 2 $ prettyVarList unboundVars) )+  where+    boundVars   = S.fromList $ frees (get rPrems ru)+    unboundVars = do+        v <- frees (get rConcs ru, get rActs ru, get rInfo ru)+        guard $ not (lvarSort v == LSortPub || v `S.member` boundVars)+        return v++-- | Report on sort clashes.+unboundReport :: OpenTheory -> WfErrorReport+unboundReport thy = do+    RuleItem ru <- get thyItems thy+    unboundCheck ("rule " ++ quote (showRuleCaseName ru) +++                  " has unbound variables: "+                 ) ru++-- | Report on facts usage.+factReports :: OpenTheory -> WfErrorReport+factReports thy = concat+    [ reservedReport, freshFactArguments, specialFactsUsage+    , factUsage, inexistentActions+    ]+  where+    ruleFacts ru =+      ( "rule " ++ quote (showRuleCaseName ru)+      , extFactInfo <$> concatMap (`get` ru) [rPrems, rActs, rConcs])++    -- NOTE: The check that the number of actual function arguments in a term+    -- agrees with the arity of the function as given by the signature is+    -- enforced by the parser and implicitly checked in 'factArity'.++    theoryFacts = -- sortednubOn (fst &&& (snd . snd)) $+          do ruleFacts <$> get thyCache thy+      <|> do RuleItem ru <- get thyItems thy+             return $ ruleFacts ru+      <|> do LemmaItem l <- get thyItems thy+             return $ (,) ("lemma " ++ quote (get lName l)) $ do+                 fa <- formulaFacts (get lFormulaE l)+                 return $ (text (show fa), factInfo fa)++    -- we must compute all important information up-front in order to+    -- mangle facts with terms with bound variables and such without them+    extFactInfo fa = (prettyLNFact fa, factInfo fa)++    factInfo :: Fact t -> (FactTag, Int, Multiplicity)+    factInfo fa    = (factTag fa, factArity fa, factMultiplicity fa)++    --- Check for usage of protocol facts with reserved names+    reservedReport = do+        (origin, fas) <- theoryFacts+        case mapMaybe reservedFactName fas of+          []   -> []+          errs -> return $ (,) "reseved names" $ foldr1 ($--$) $+              wrappedText ("The " ++ origin +++                           " contains facts with reserved names:")+            : map (nest 2) errs++    reservedFactName (ppFa, info@(ProtoFact _ name _, _,_))+      | map toLower name `elem` ["fr","ku","kd","out","in"] =+          return $ ppFa $-$ text ("show:" ++ show info)+    reservedFactName _ = Nothing++    freshFactArguments = do+       ru                      <- thyProtoRules thy+       fa@(Fact FreshFact [m]) <- get rPrems ru+       guard (not (isMsgVar m || isFreshVar m))+       return $ (,) "Fr facts must only use a fresh- or a msg-variable" $+           text ("rule " ++ quote (showRuleCaseName ru)) <->+           text "fact:" <-> prettyLNFact fa++    -- Check for the usage of special facts at wrong positions+    specialFactsUsage = do+       ru <- thyProtoRules thy+       let lhs = [ fa | fa <- get rPrems ru+                      , factTag fa `elem` [KUFact, KDFact, OutFact] ]+           rhs = [ fa | fa <- get rConcs ru+                      , factTag fa `elem` [FreshFact, KUFact, KDFact, InFact] ]+           check _   []  = mzero+           check msg fas = return $ (,) "special fact usage" $+               text ("rule " ++ quote (showRuleCaseName ru)) <-> text msg $-$+               (nest 2 $ fsep $ punctuate comma $ map prettyLNFact fas)++       msum [ check "uses disallowed facts on left-hand-side:"  lhs+            , check "uses disallowed facts on right-hand-side:" rhs ]++    -- Check for facts with equal name modulo capitalization, but different+    -- multiplicity or arity.+    factUsage = do+       clash <- clashesOn factIdentifier (snd . snd) theoryFacts'+       return $ (,) "fact usage" $ numbered' $ do+           (origin, (ppFa, info@(tag, _, _))) <- clash+           return $ text (origin +++                          ", fact " ++ show (map toLower $ showFactTag tag) +++                          ": " ++ showInfo info)+                    $-$ nest 2 ppFa+      where+        showInfo (tag, k, multipl) = show $ (showFactTag tag, k, multipl)+        theoryFacts'   = [ (ru, fa) | (ru, fas) <- theoryFacts, fa <- fas ]+        factIdentifier (_, (_, (tag, _, _))) = map toLower $ showFactTag tag+++    -- Check that every fact referenced in a formula is present as an action+    -- of a protocol rule. We have to add the linear "K/1" fact, as the+    -- WF-check cannot rely on a loaded intruder theory.+    ruleActions = S.fromList $ map factInfo $+          kLogFact undefined+        : dedLogFact undefined+        : Fact KUFact [undefined, undefined]+        : (do RuleItem ru <- get thyItems thy; get rActs ru)++    inexistentActions = do+        LemmaItem l <- get thyItems thy+        fa <- sortednub $ formulaFacts (get lFormulaE l)+        let info = factInfo fa+            name = get lName l+        if info `S.member` ruleActions+          then []+          else return $ (,) "lemma actions" $+                 text ("lemma " ++ quote name ++ " references action ") $-$+                 nest 2 (text $ show info) $-$+                 text "but no rule has such an action."+++-- | Gather all facts referenced in a formula.+formulaFacts :: Formula s c v -> [Fact (VTerm c (BVar v))]+formulaFacts =+    foldFormula atomFacts+      (const mempty)+      id+      (const mappend) (const $ const id)+  where+    atomFacts (Action _ fa)   = [fa]+    atomFacts (EqE _ _)       = mempty+    atomFacts (Less _ _)      = mempty+    atomFacts (Last _)        = mempty++-- | Gather all terms referenced in a formula.+formulaTerms :: Formula s c v -> [VTerm c (BVar v)]+formulaTerms =+    foldFormula atomTerms (const mempty) id (const mappend) (const $ const id)+  where+    atomTerms (Action i fa)   = i : factTerms fa+    atomTerms (EqE t s)       = [t, s]+    atomTerms (Less i j)      = [i, j]+    atomTerms (Last i)        = [i]+++-- | Check for mistakes in lemmas.+--+-- TODO: Perhaps a lot of errors would be captured when making the signature+-- of facts, term, and atom constructors explicit.+formulaReports :: OpenTheory -> WfErrorReport+formulaReports thy = do+    LemmaItem l <- get thyItems thy+    let header = "lemma " ++ quote (get lName l)+        fmE    = get lFormulaE l+    msum [ ((,) "quantifier sorts") <$> checkQuantifiers header fmE+         , ((,) "formula terms")    <$> checkTerms header fmE+         , ((,) "guardedness")      <$> checkGuarded header fmE+         ]+  where+    -- check that only message and node variables are used+    checkQuantifiers header fm+      | null disallowed = []+      | otherwise       = return $ fsep $+          (text $ header ++ "uses quantifiers with wrong sort:") :+          (punctuate comma $ map (nest 2 . text . show) disallowed)+      where+        binders    = foldFormula (const mempty) (const mempty) id (const mappend)+                         (\_ binder rest -> binder : rest) fm+        disallowed = filter (not . (`elem` [LSortMsg, LSortNode]) . snd) binders++    -- check that only bound variables and public names are used+    checkTerms header fm+      | null offenders = []+      | otherwise      = return $+          (fsep $+            (text $ header ++ " uses terms of the wrong form:") :+            (punctuate comma $ map (nest 2 . text . quote . show) offenders)+          ) $--$+          wrappedText+            "The only allowed terms are public names and bound node and message\+            \ variables. If you encounter free message variables, then you might\+            \ have forgotten a #-prefix. Sort prefixes can only be dropped where\+            \ this is unambiguous"+      where+        offenders = filter (not . allowed) $ formulaTerms fm+        allowed (viewTerm -> Lit (Var (Bound _)))        = True+        allowed (viewTerm -> Lit (Con (Name PubName _))) = True+        allowed _                                        = False++    -- check that the formula can be converted to a guarded formula+    checkGuarded header fm = case formulaToGuarded fm of+        Left err -> return $+            text (header ++ " cannot be converted to a guarded formula:") $-$+            nest 2 (text err)+        Right _  -> []+++++-- | Check that all rules are multipliation restricted. Compared+-- to the definition in the paper we are slightly more lenient.+-- We also accept a rule that is an instance of a multiplication+-- restricted rule.+-- 1. Consistently abstract terms with outermost reducible function symbols+--    occuring in lhs with fresh variables in rule.+-- 2. check vars(rhs) subset of vars(lhs) u V_Pub for abstracted rule for abstracted variables.+-- 3. check that * does not occur in rhs of abstracted rule.+multRestrictedReport :: OpenTheory -> WfErrorReport+multRestrictedReport thy = do+    ru <- theoryRules thy+    (,) "multiplication restriction of rules" <$>+        case restrictedFailures ru of+          ([],[]) -> []+          (mults, unbounds) ->+              return $+                (text "The following rule is not multiplication restricted:")+                $-$ (nest 2 (prettyProtoRuleE ru))+                $-$ (text "")+                $-$ (text "After replacing reducible function symbols in lhs with variables:")+                $-$ (nest 2 $ prettyProtoRuleE (abstractRule ru))+                $-$ (text "")+                $-$ (if null mults then mempty+                     else nest 2 $ (text "Terms with multiplication: ") <-> (prettyLNTermList mults))+                $-$ (if null unbounds then mempty+                     else nest 2 $ (text "Variables that occur only in rhs: ") <-> (prettyVarList unbounds))+  where+    abstractRule ru@(Rule i lhs acts rhs) =+        (`evalFreshAvoiding` ru) .  (`evalBindT` noBindings) $ do+        Rule i <$> mapM (traverse abstractTerm) lhs+               <*> mapM (traverse replaceAbstracted) acts+               <*> mapM (traverse replaceAbstracted) rhs++    abstractTerm (viewTerm -> FApp (NonAC o) args) | o `S.member` irreducible =+        fAppNonAC o <$> mapM abstractTerm args+    abstractTerm (viewTerm -> Lit l) = return $ lit l+    abstractTerm t = varTerm <$> importBinding (`LVar` sortOfLNTerm t) t "x"++    replaceAbstracted t = do+        b <- lookupBinding t+        case b of+          Just v -> return $ varTerm v+          Nothing ->+              case viewTerm t of+                FApp o args ->+                    fApp o <$> mapM replaceAbstracted args+                Lit l       -> return $ lit l++    restrictedFailures ru = (mults, unbound ruAbstr \\ unbound ru)+      where+        ruAbstr = abstractRule ru++        mults = [ mt | Fact _ ts <- get rConcs ru, t <- ts, mt <- multTerms t ]++        multTerms t@(viewTerm -> FApp (AC Mult) _)  = [t]+        multTerms   (viewTerm -> FApp _         as) = concatMap multTerms as+        multTerms _                                 = []++    unbound ru = [v | v <- frees (get rConcs ru) \\ frees (get rPrems ru)+                 , lvarSort v /= LSortPub ]+++    irreducible = irreducibleFunctionSymbols $ get (sigpMaudeSig . thySignature) thy++++-- | All 2-multicombinations of a list.+-- multicombine2 :: [a] -> [(a,a)]+-- multicombine2 xs0 = do (x,xs) <- zip xs0 $ tails xs0; (,) x <$> xs+++------------------------------------------------------------------------------+-- Theory+------------------------------------------------------------------------------++++-- | Returns a list of errors, if there are any.+checkWellformedness :: OpenTheory+                    -> WfErrorReport+checkWellformedness thy = concatMap ($ thy)+    [ unboundReport+    , freshNamesReport+    , publicNamesReport+    , ruleSortsReport+    , factReports+    , formulaReports+    , multRestrictedReport+    ]++-- | Adds a note to the end of the theory, if it is not well-formed.+noteWellformedness :: WfErrorReport -> OpenTheory -> OpenTheory+noteWellformedness report thy = addComment (prettyWfErrorReport report) thy+
− src/Theory/Wellformedness.hs 
@@ -1,533 +0,0 @@-{-# LANGUAGE ViewPatterns #-}--- |--- Copyright   : (c) 2010-2012 Simon Meier & Benedikt Schmidt--- License     : GPL v3 (see LICENSE)--- --- Maintainer  : Simon Meier <iridcode@gmail.com>--- Portability : GHC only------ Wellformedness checks for intruder variants, protocol rules, and--- properties.------ The following checks are/should be performed --- (FIXME: compare the list below to what is really implemented.)---   ---   [protocol rules] ------     1. no fresh names in rule. (protocol cond. 1)---     ==> freshNamesReport------     2. no Out or K facts in premises. (protocol cond. 2)---     ==> factReports------     3. no Fr, In, or K facts in conclusions. (protocol cond. 3)---     ==> factReports------     4. vars(rhs) subset of vars(lhs) u V_Pub---     ==> multRestrictedReport------     5. lhs does not contain reducible function symbols (*-restricted (a))---     ==> multRestrictedReport------     6. rhs does not contain * (*-restricted (b))---     ==> multRestrictedReport------     7. all facts are used with the same arity.------     8. fr, in, and out, facts are used with arity 1.------     9. fr facts are used with a variable of sort msg or sort fresh------     10. fresh facts of the same rule contain different variables. [TODO]------     11. no protocol fact uses a reserved name => ---        [TODO] change parser to ensure this and pretty printer to show this.------   [security properties]------     1. all facts occur with the same arity in the action of some---        protocol rule.------     2. no node variable is used in a message position and vice versa.-------module Theory.Wellformedness (--  -- * Wellformedness checking-    WfErrorReport-  , checkWellformedness-  , noteWellformedness--  , prettyWfErrorReport-  ) where--import           Prelude hiding (id, (.))--import           Data.Char-import           Data.Generics.Uniplate.Data (universeBi)-import           Data.List-import           Data.Label-import           Data.Maybe-import           Data.Monoid (mempty, mappend)-import qualified Data.Set      as S-import           Control.Basics-import           Control.Category-import           Data.Traversable hiding (mapM)--import           Control.Monad.Bind--import           Term.Maude.Signature-import           Extension.Prelude-import           Text.PrettyPrint.Class-import           Theory----------------------------------------------------------------------------------- Types for error reports---------------------------------------------------------------------------------type Topic         = String-type WfError       = (Topic, Doc)-type WfErrorReport = [WfError]--prettyWfErrorReport :: WfErrorReport -> Doc-prettyWfErrorReport []     = text "All well-formedness checks were successful."-prettyWfErrorReport report = foldr1 ($-$)-  [ text "Error: the following well-formedness checks failed!"-  , text ""-  , vcat . intersperse (text "") . map ppTopic $ groupOn fst report-  ]-  where-    ppTopic []                 = error "prettyWfErrorReport: groupOn returned empty list"-    ppTopic errs@((topic,_):_) =-      text topic <> colon $-$ -      (nest 2 . vcat . intersperse (text "") $ map snd errs)-    ----------------------------------------------------------------------------------- Utilities----------------------------------------------------------------------------------- | All protocol rules of a theory.--- thyProtoRules :: OpenTheory ->-thyProtoRules :: OpenTheory -> [ProtoRuleE]-thyProtoRules thy = [ ru | RuleItem ru <- get thyItems thy ]-    --- | Lower-case a string.-lowerCase :: String -> String-lowerCase = map toLower---- | Pretty-print a comma, separated list of 'LVar's.-prettyVarList :: Document d => [LVar] -> d-prettyVarList = fsep . punctuate comma . map prettyLVar---- | Pretty-print a comma, separated list of 'LNTerms's.-prettyLNTermList :: Document d => [LNTerm] -> d-prettyLNTermList = fsep . punctuate comma . map prettyLNTerm---- | Wrap strings at word boundaries.-wrappedText :: Document d => String -> d-wrappedText = fsep . map text . words---- | Clashes-clashesOn :: (Ord b, Ord c)-          => (a -> b) -- ^ This projection-          -> (a -> c) -- ^ must determine this projection.-          -> [a] -> [[a]]-clashesOn f g xs = do-    grp <- groupOn f $ sortOn f xs-    guard (length (sortednubOn g grp) >= 2)-    return grp-    --- | Nice quoting.-quote :: String -> String-quote cs = '`' : cs ++ "'"----------------------------------------------------------------------------------- Checks------------------------------------------------------------------------------------ | Check that the protocol rules are well-formed.-sortsClashCheck :: HasFrees t => String -> t -> WfErrorReport-sortsClashCheck info t = case clashesOn removeSort id $ frees t of-    [] -> []-    cs -> return $ -            ( "sorts"-            , text info $-$ (nest 2 $ numbered' $ map prettyVarList cs)-            )-  where-    removeSort lv = (lowerCase (lvarName lv), lvarIdx lv)---- | Report on sort clashes.-ruleSortsReport :: OpenTheory -> WfErrorReport-ruleSortsReport thy = do-    ru <- thyProtoRules thy-    sortsClashCheck ("rule " ++ quote (showRuleCaseName ru) ++ -                     " clashing sorts, casings, or multiplicities:") ru---- | Report on fresh names.-freshNamesReport :: OpenTheory -> WfErrorReport-freshNamesReport thy = do-    ru <- thyProtoRules thy-    case filter ((LSortFresh ==) . sortOfName) $ universeBi ru of-      []    -> []-      names -> return $ (,) "fresh names" $ fsep $-          text ( "rule " ++ quote (showRuleCaseName ru) ++ ": " ++-                 "fresh names are not allowed in rule:" )-        : punctuate comma (map (nest 2 . text . show) names)---- | Report on capitalization of public names.-publicNamesReport :: OpenTheory -> WfErrorReport-publicNamesReport thy =-    case findClashes publicNames of-      []      -> []-      clashes -> return $ (,) topic $ numbered' $-          map (nest 2 . fsep . punctuate comma . map ppRuleAndName) clashes-  where-    topic       = "public names with mismatching capitalization"-    publicNames = do-        ru <- thyProtoRules thy-        (,) (showRuleCaseName ru) <$> -            (filter ((LSortPub ==) . sortOfName) $ universeBi ru)-    findClashes   = clashesOn (map toLower . show . snd) (show . snd)-    ppRuleAndName (ruName, pub) = -        text $ "rule " ++ show ruName ++ " name " ++ show pub---- | Check whether a rule has unbound variables.-unboundCheck :: HasFrees i => String -> Rule i -> WfErrorReport-unboundCheck info ru-    | null unboundVars = []-    | otherwise        = return $-        ( "unbound"-        , text info $-$ (nest 2 $ prettyVarList unboundVars) )-  where -    boundVars   = S.fromList $ frees (get rPrems ru)-    unboundVars = do-        v <- frees (get rConcs ru, get rActs ru, get rInfo ru)-        guard $ not (lvarSort v == LSortPub || v `S.member` boundVars)-        return v---- | Report on sort clashes.-unboundReport :: OpenTheory -> WfErrorReport-unboundReport thy = do-    RuleItem ru <- get thyItems thy-    unboundCheck ("rule " ++ quote (showRuleCaseName ru) ++ -                  " has unbound variables: "-                 ) ru---- | Report on facts usage.-factReports :: OpenTheory -> WfErrorReport-factReports thy = concat-    [ reservedReport, freshFactArguments, specialFactsUsage-    , factUsage, inexistentActions-    ]-  where-    ruleFacts ru = -      ( "rule " ++ quote (showRuleCaseName ru)-      , extFactInfo <$> concatMap (`get` ru) [rPrems, rActs, rConcs])--    -- FIXME: Possibly the check that term arity agrees with fact-tag arity-    -- should be made here instead of just throwing an error, as implemented-    -- in 'factArity'.--    theoryFacts = -- sortednubOn (fst &&& (snd . snd)) $-          do ruleFacts <$> get thyCache thy-      <|> do RuleItem ru <- get thyItems thy-             return $ ruleFacts ru-      <|> do LemmaItem l <- get thyItems thy-             return $ (,) ("lemma " ++ quote (get lName l)) $ do-                 fa <- formulaFacts (get lFormulaE l)-                 return $ (text (show fa), factInfo fa)-      <|> do return $ (,) "unique_insts declaration" $ do-               tag <- S.toList $ get (sigpUniqueInsts . thySignature) thy -               return $ ( text $ showFactTagArity tag-                        , (tag, factTagArity tag, factTagMultiplicity tag)-                        )--    -- we must compute all important information up-front in order to-    -- mangle facts with terms with bound variables and such without them-    extFactInfo fa = (prettyLNFact fa, factInfo fa)--    factInfo :: Fact t -> (FactTag, Int, Multiplicity)-    factInfo fa    = (factTag fa, factArity fa, factMultiplicity fa)--    --- Check for usage of protocol facts with reserved names-    reservedReport = do-        (origin, fas) <- theoryFacts-        case mapMaybe reservedFactName fas of-          []   -> []-          errs -> return $ (,) "reseved names" $ foldr1 ($--$) $-              wrappedText ("The " ++ origin ++ -                           " contains facts with reserved names:")-            : map (nest 2) errs --    reservedFactName (ppFa, info@(ProtoFact _ name _, _,_))-      | map toLower name `elem` ["fr","ku","kd","out","in"] =-          return $ ppFa $-$ text ("show:" ++ show info)-    reservedFactName _ = Nothing--    freshFactArguments = do-       ru                      <- thyProtoRules thy-       fa@(Fact FreshFact [m]) <- get rPrems ru-       guard (not (isMsgVar m || isFreshVar m))-       return $ (,) "Fr facts must only use a fresh- or a msg-variable" $-           text ("rule " ++ quote (showRuleCaseName ru)) <->-           text "fact:" <-> prettyLNFact fa--    -- Check for the usage of special facts at wrong positions-    specialFactsUsage = do-       ru <- thyProtoRules thy-       let lhs = [ fa | fa <- get rPrems ru-                      , factTag fa `elem` [KUFact, KDFact, OutFact] ]-           rhs = [ fa | fa <- get rConcs ru-                      , factTag fa `elem` [FreshFact, KUFact, KDFact, InFact] ]-           check _   []  = mzero-           check msg fas = return $ (,) "special fact usage" $-               text ("rule " ++ quote (showRuleCaseName ru)) <-> text msg $-$-               (nest 2 $ fsep $ punctuate comma $ map prettyLNFact fas)--       msum [ check "uses disallowed facts on left-hand-side:"  lhs-            , check "uses disallowed facts on right-hand-side:" rhs ]--    -- Check for facts with equal name modulo capitalization, but different-    -- multiplicity or arity.-    factUsage = do-       clash <- clashesOn factIdentifier (snd . snd) theoryFacts'-       return $ (,) "fact usage" $ numbered' $ do-           (origin, (ppFa, info@(tag, _, _))) <- clash-           return $ text (origin ++-                          ", fact " ++ show (map toLower $ showFactTag tag) ++-                          ": " ++ showInfo info)-                    $-$ nest 2 ppFa-      where-        showInfo (tag, k, multipl) = show $ (showFactTag tag, k, multipl)-        theoryFacts'   = [ (ru, fa) | (ru, fas) <- theoryFacts, fa <- fas ]-        factIdentifier (_, (_, (tag, _, _))) = map toLower $ showFactTag tag---    -- Check that every fact referenced in a formula is present as an action-    -- of a protocol rule. We have to add the linear "K/1" fact, as the-    -- WF-check cannot rely on a loaded intruder theory.-    ruleActions = S.fromList $ map factInfo $ -        kLogFact undefined : dedLogFact undefined :-        (do RuleItem ru <- get thyItems thy; get rActs ru)--    inexistentActions = do-        LemmaItem l <- get thyItems thy-        fa <- sortednub $ formulaFacts (get lFormulaE l)-        let info = factInfo fa-            name = get lName l-        if info `S.member` ruleActions -          then []-          else return $ (,) "lemma actions" $-                 text ("lemma " ++ quote name ++ " references action ") $-$-                 nest 2 (text $ show info) $-$-                 text "but no rule has such an action."--   -    --- | Gather all facts referenced in a formula.-formulaFacts :: Formula s c v -> [Fact (VTerm c (BVar v))]-formulaFacts = -    foldFormula atomFacts -      (const mempty) -      id -      (const mappend) (const $ const id)-  where-    atomFacts (Action _ fa)   = [fa]-    atomFacts (EqE _ _)       = mempty-    atomFacts (Less _ _)      = mempty-    atomFacts (Last _)        = mempty-    atomFacts (DedBefore _ _) = mempty-    atomFacts (EdgeA _ _)     = mempty---- | Gather all terms referenced in a formula.-formulaTerms :: Formula s c v -> [VTerm c (BVar v)]-formulaTerms = -    foldFormula atomTerms (const mempty) id (const mappend) (const $ const id)-  where-    atomTerms (Action i fa)   = i : factTerms fa-    atomTerms (EqE t s)       = [t, s]-    atomTerms (Less i j)      = [i, j]-    atomTerms (Last i)        = [i]-    atomTerms (DedBefore t i) = [t, i]-    atomTerms (EdgeA x y)     = [fst x, fst y]----- | Check for mistakes in lemmas.------ TODO: Perhaps a lot of errors would be captured when making the signature--- of facts, term, and atom constructors explicit.-formulaReports :: OpenTheory -> WfErrorReport-formulaReports thy = do-    LemmaItem l <- get thyItems thy-    let header = "lemma " ++ quote (get lName l)-        fmE    = get lFormulaE l-    msum [ ((,) "quantifier sorts") <$> checkQuantifiers header fmE-         , ((,) "formula terms")    <$> checkTerms header fmE-         , ((,) "guardedness")      <$> checkGuarded header fmE -         ]-  where-    -- check that only message and node variables are used-    checkQuantifiers header fm-      | null disallowed = []-      | otherwise       = return $ fsep $ -          (text $ header ++ "uses quantifiers with wrong sort:") :-          (punctuate comma $ map (nest 2 . text . show) disallowed)-      where-        binders    = foldFormula (const mempty) (const mempty) id (const mappend) -                         (\_ binder rest -> binder : rest) fm-        disallowed = filter (not . (`elem` [LSortMsg, LSortNode]) . snd) binders--    -- check that only bound variables and public names are used-    checkTerms header fm-      | null offenders = []-      | otherwise      = return $ -          (fsep $-            (text $ header ++ " uses terms of the wrong form:") :-            (punctuate comma $ map (nest 2 . text . quote . show) offenders)-          ) $--$-          wrappedText -            "The only allowed terms are public names and bound node and message\-            \ variables. If you encounter free message variables, then you might\-            \ have forgotten a #-prefix. Sort prefixes can only be dropped where\-            \ this is unambiguous"-      where-        offenders = filter (not . allowed) $ formulaTerms fm-        allowed (viewTerm -> Lit (Var (Bound _)))        = True-        allowed (viewTerm -> Lit (Con (Name PubName _))) = True-        allowed _                                        = False--    -- check that the formula can be converted to a guarded formula-    checkGuarded header fm = case fromFormulaNegate fm of-        Left err -> return $ -            text (header ++ " cannot be converted to a guarded formula:") $-$-            nest 2 (text err)-        Right _  -> []--             --uniqueInstsReport :: OpenTheory -> WfErrorReport-uniqueInstsReport thy = do-    tag <- S.toList $ get (sigpUniqueInsts . thySignature) thy-    (,) "unique fact instances" <$> -        if (Persistent == factTagMultiplicity tag)-          then return $ text $ showFactTagArity tag ++ " is persistent"-          else msum -                [ checkAtMostOneConc tag-                , checkCopying tag-                ]-  where-    checkAtMostOneConc tag = do-        ru <- thyProtoRules thy-        let occs = length $ filter ((tag ==) . factTag) $ get rConcs ru-        guard (occs > 1)-        return $ wrappedText $-            "Failed to prove unique fact instances of " ++-            showFactTagArity tag ++ ", as it occurs " ++ show occs ++-            " times as a conclusion of rule '" ++ showRuleCaseName ru ++ "'."--    checkCopying _f = [] -- FIXME: Implement check.-    {--        (ru1, ru2) <- -      where-        rules = -            filter (any (any ((f ==) . factSymbol) . get rPrems)) $-            thyProtoRules thy-    -}----- | Check that all rules are multipliation restricted. Compared--- to the definition in the paper we are slightly more lenient.--- We also accept a rule that is an instance of a multiplication--- restricted rule.--- 1. Consistently abstract terms with outermost reducible function symbols---    occuring in lhs with fresh variables in rule.--- 2. check vars(rhs) subset of vars(lhs) u V_Pub for abstracted rule for abstracted variables.--- 3. check that * does not occur in rhs of abstracted rule.-multRestrictedReport :: OpenTheory -> WfErrorReport-multRestrictedReport thy = do-    ru <- theoryRules thy-    (,) "multiplication restriction of rules" <$>-        case restrictedFailures ru of-          ([],[]) -> []-          (mults, unbounds) ->-              return $-                (text "The following rule is not multiplication restricted:")-                $-$ (nest 2 (prettyProtoRuleE ru))-                $-$ (text "")-                $-$ (text "After replacing reducible function symbols in lhs with variables:")-                $-$ (nest 2 $ prettyProtoRuleE (abstractRule ru))-                $-$ (text "")-                $-$ (if null mults then mempty-                     else nest 2 $ (text "Terms with multiplication: ") <-> (prettyLNTermList mults))-                $-$ (if null unbounds then mempty-                     else nest 2 $ (text "Variables that occur only in rhs: ") <-> (prettyVarList unbounds))-  where-    abstractRule ru@(Rule i lhs acts rhs) =-        (`evalFreshAvoiding` ru) .  (`evalBindT` noBindings) $ do-        Rule i <$> mapM (traverse abstractTerm) lhs-               <*> mapM (traverse replaceAbstracted) acts-               <*> mapM (traverse replaceAbstracted) rhs--    abstractTerm (viewTerm -> FApp (NonAC o) args) | o `S.member` irreducible =-        fAppNonAC o <$> mapM abstractTerm args-    abstractTerm (viewTerm -> Lit l) = return $ lit l-    abstractTerm t = varTerm <$> importBinding (`LVar` sortOfLNTerm t) t "x"--    replaceAbstracted t = do-        b <- lookupBinding t-        case b of-          Just v -> return $ varTerm v-          Nothing ->-              case viewTerm t of-                FApp o args ->-                    fApp o <$> mapM replaceAbstracted args-                Lit l       -> return $ lit l--    restrictedFailures ru = (mults, unbound ruAbstr \\ unbound ru)-      where-        ruAbstr = abstractRule ru--        mults = [ mt | Fact _ ts <- get rConcs ru, t <- ts, mt <- multTerms t ]--        multTerms t@(viewTerm -> FApp (AC Mult) _)  = [t]-        multTerms   (viewTerm -> FApp _         as) = concatMap multTerms as-        multTerms _                                 = []--    unbound ru = [v | v <- frees (get rConcs ru) \\ frees (get rPrems ru)-                 , lvarSort v /= LSortPub ]---    irreducible = irreducibleFunctionSymbols $ get (sigpMaudeSig . thySignature) thy------ | All 2-multicombinations of a list.--- multicombine2 :: [a] -> [(a,a)]--- multicombine2 xs0 = do (x,xs) <- zip xs0 $ tails xs0; (,) x <$> xs------------------------------------------------------------------------------------ Theory------------------------------------------------------------------------------------- | Returns a list of errors, if there are any.-checkWellformedness :: OpenTheory-                    -> WfErrorReport-checkWellformedness thy = concatMap ($ thy)-    [ unboundReport-    , freshNamesReport-    , publicNamesReport-    , ruleSortsReport -    , factReports-    , formulaReports-    , uniqueInstsReport-    , multRestrictedReport-    ]---- | Adds a note to the end of the theory, if it is not well-formed.-noteWellformedness :: WfErrorReport -> OpenTheory -> OpenTheory-noteWellformedness report thy = addComment (prettyWfErrorReport report) thy-
src/Web/Dispatch.hs view
@@ -15,37 +15,37 @@ -- that we have the warning again for our code. {-# OPTIONS_GHC -fno-warn-name-shadowing #-} -module Web.Dispatch +module Web.Dispatch   ( withWebUI   , ImageFormat(..)   ) where -import Theory-import Web.Types-import Web.Handler-import Web.Settings+import           Theory+import           Web.Handler+import           Web.Settings+import           Web.Types -import Yesod.Core-import Yesod.Static-import Network.Wai+import           Network.Wai+import           Yesod.Core+import           Yesod.Static -import qualified Data.Map as M-import qualified Data.Text as T-import qualified Data.ByteString as B-import qualified Control.Exception as E-import qualified Data.Binary as Bin+import qualified Control.Exception      as E+import qualified Data.Binary            as Bin+import qualified Data.ByteString        as B+import qualified Data.Map               as M+import qualified Data.Text              as T -import Data.List-import Data.Maybe-import Data.Time.LocalTime-import Control.Concurrent-import Control.Monad-import Control.Applicative-import Control.Monad.IO.Class+import           Control.Applicative+import           Control.Concurrent+import           Control.Monad+import           Control.Monad.IO.Class+import           Data.List+import           Data.Maybe+import           Data.Time.LocalTime -import System.FilePath-import System.Directory+import           System.Directory+import           System.FilePath  -- | Create YesodDispatch instance for the interface. -- mkYesodDispatch "WebUI" resourcesWebUI@@ -74,10 +74,13 @@           -> Bool                            -- ^ Show debugging messages?           -> FilePath                        -- ^ Path to static content directory           -> FilePath                        -- ^ Path to dot binary-          -> ImageFormat                       -- ^ The preferred image format+          -> ImageFormat                     -- ^ The preferred image format+          -> AutoProver                      -- ^ The default autoprover.           -> (Application -> IO b)           -- ^ Function to execute           -> IO b-withWebUI readyMsg thDir loadState autosave thLoader thParser thCloser debug' stPath dotCmd' imgFormat' f = do+withWebUI readyMsg thDir loadState autosave thLoader thParser thCloser debug'+          stPath dotCmd' imgFormat' defaultAutoProver' f+  = do     thy    <- getTheos     thrVar <- newMVar M.empty     thyVar <- newMVar thy@@ -85,7 +88,7 @@     when autosave $ createDirectoryIfMissing False autosaveDir     (`E.finally` shutdownThreads thrVar) $       f =<< toWaiApp WebUI-        { workDir            = thDir +        { workDir            = thDir         , parseThy           = liftIO . thParser         , closeThy           = thCloser         , getStatic          = st@@ -94,6 +97,7 @@         , autosaveProofstate = autosave         , dotCmd             = dotCmd'         , imageFormat        = imgFormat'+        , defaultAutoProver  = defaultAutoProver'         , debug              = debug'         }   where@@ -112,7 +116,7 @@                      _            -> return Nothing          return $ M.fromList $ catMaybes thys -       else loadTheories readyMsg thDir thLoader+       else loadTheories readyMsg thDir thLoader defaultAutoProver'      shutdownThreads thrVar = do       m <- modifyMVar thrVar $ \m -> return (M.empty, m)@@ -123,8 +127,12 @@   -- | Load theories from the current directory, generate map.-loadTheories :: String -> FilePath -> (FilePath -> IO ClosedTheory) -> IO TheoryMap-loadTheories readyMsg thDir thLoader = do+loadTheories :: String+             -> FilePath+             -> (FilePath -> IO ClosedTheory)+             -> AutoProver+             -> IO TheoryMap+loadTheories readyMsg thDir thLoader autoProver = do     mkImageDir     thPaths <- filter (".spthy" `isSuffixOf`) <$> getDirectoryContents thDir     theories <- catMaybes <$> mapM loadThy (zip [1..] (map (thDir </>) thPaths))@@ -136,12 +144,15 @@       let dir = thDir </> imageDir       existsDir <- doesDirectoryExist dir       unless existsDir (createDirectory dir)-    +     -- Load theories     loadThy (idx, path) = E.handle catchEx $ do         thy <- thLoader path         time <- getZonedTime-        return $ Just (idx, TheoryInfo idx thy time Nothing True (Local path))+        return $ Just+          ( idx+          , TheoryInfo idx thy time Nothing True (Local path) autoProver+          )       where         -- Exception handler (if loading theory fails)         catchEx :: E.SomeException -> IO (Maybe (TheoryIdx, TheoryInfo))
src/Web/Hamlet.hs view
@@ -10,39 +10,39 @@ -}  {-# LANGUAGE-    TypeFamilies, QuasiQuotes, TypeSynonymInstances, +    TypeFamilies, QuasiQuotes, TypeSynonymInstances,     PatternGuards, FlexibleInstances, CPP #-} {-# OPTIONS_GHC -fno-warn-orphans #-}  module Web.Hamlet (     rootTpl-  , overviewTpl  +  , overviewTpl   ) where -import Theory-import Web.Types-import Web.Theory-import Data.Label-import Text.PrettyPrint.Html+import           Data.Label+import           Text.PrettyPrint.Html+import           Theory+import           Web.Theory+import           Web.Types -import Yesod.Core+import           Yesod.Core -- import Yesod.Form -- import Text.Hamlet -import Control.Monad.IO.Class (liftIO)-import Data.Ord-import Data.List-import Data.Time.Format-import Data.Version (showVersion)-import qualified Data.Map as M+import           Control.Monad.IO.Class (liftIO)+import           Data.List+import qualified Data.Map               as M+import           Data.Ord+import           Data.Time.Format+import           Data.Version           (showVersion) -- import qualified Data.Text as T-import Text.Blaze.Html5 (preEscapedString)+import           Text.Blaze.Html5       (preEscapedString)  -- import Control.Monad.RWS (runRWST)-import qualified Control.Exception as E-import System.Locale+import qualified Control.Exception      as E+import           System.Locale -import Paths_tamarin_prover (version)+import           Paths_tamarin_prover   (version)  -- Quasi-quotation syntax changed from GHC 6 to 7, -- so we need this switch in order to support both@@ -67,7 +67,7 @@  -- | Run a ThHtml value, catch exceptions. wrapThHtml :: HtmlDoc Doc -> IO Widget-wrapThHtml th = +wrapThHtml th =     E.catch (return $ wrapHtmlDoc th) handleEx   where     -- handleEx :: HamletValue h => E.SomeException -> IO h@@ -123,14 +123,14 @@       <p>         \^{theoriesTpl theories}       <h2>Loading a new theory-      <p+      <p>         You can load a new theory file from disk in order to work with it.       <form class=root-form enctype="multipart/form-data" action=@{RootR} method=POST>         Filename:         <input type=file name="uploadedTheory">         <div .submit-form>           <input type=submit value="Load new theory">-      <p>Note: You can save a theory by downloading the source. +      <p>Note: You can save a theory by downloading the source.   |]  -- | Template for listing theories.@@ -153,7 +153,7 @@   |]   where     processMap =-      groupBy (\x y -> comparing tiName x y == EQ) . +      groupBy (\x y -> comparing tiName x y == EQ) .       sortBy (comparing snd) . M.toList      tiName = get thyName . tiTheory . snd@@ -282,12 +282,12 @@         -> IO Widget pathTpl _ info TheoryHelp = return [whamlet|     <h3>Theory information</h3>-      <ul+      <ul>         <li>Theory: #{get thyName $ tiTheory info}         <li>Loaded at #{formatTime defaultTimeLocale "%T" $ tiTime info}         <li>Origin: #{show $ tiOrigin info}     <div id="help">-      <h3>Quick introduction</h3>+      <h3>Quick introduction       <noscript>         <div class="warning">           Warning: JavaScript must be enabled for the <span class="tamarin">Tamarin</span> prover GUI to function properly.
src/Web/Handler.hs view
@@ -39,61 +39,52 @@   ) where -import Theory (+import           Theory                       (     ClosedTheory,-    thyName, -    -- lName,-    -- lookupLemma, addLemma, -    removeLemma,-    openTheory, -    mapProverProof, sorryProver, autoProver, cutOnAttackDFS,-    prettyClosedTheory, prettyOpenTheory -    -- prettyProof, prettyLemma, prettyClosedTheory, prettyOpenTheory +    thyName, removeLemma,+    openTheory, sorryProver, runAutoProver,+    prettyClosedTheory, prettyOpenTheory   )--- import Theory.Parser-import Theory.Proof.Sequent.Dot-import Web.Types-import Web.Hamlet-import Web.Theory-import Web.Instances ()-import Web.Settings-import Text.PrettyPrint.Html+import           Theory.Proof (apHeuristic)+import           Text.PrettyPrint.Html+import           Theory.Constraint.System.Dot+import           Web.Hamlet+import           Web.Instances                ()+import           Web.Settings+import           Web.Theory+import           Web.Types -import Yesod.Core-import Yesod.Json()--- import Yesod.Form--- import Text.Hamlet+import           Yesod.Core+import           Yesod.Json() -import Data.Maybe-import Data.Aeson-import Data.Label-import Data.String (fromString)--- import Data.Traversable (traverse)+import           Data.Aeson+import           Data.Label+import           Data.Maybe+import           Data.String                  (fromString) -import qualified Data.Map as M-import qualified Data.Text as T-import qualified Data.Traversable as Tr-import qualified Data.ByteString.Lazy.Char8 as BS-import Data.Text.Encoding-import qualified Blaze.ByteString.Builder   as B-import Network.HTTP.Types ( urlDecode )-import Text.Blaze.Html5 (toHtml)+import qualified Blaze.ByteString.Builder     as B+import qualified Data.ByteString.Lazy.Char8   as BS+import qualified Data.Map                     as M+import qualified Data.Text                    as T+import           Data.Text.Encoding+import qualified Data.Traversable             as Tr+import           Network.HTTP.Types           ( urlDecode )+import           Text.Blaze.Html5             (toHtml) -import Control.Monad-import Control.Monad.IO.Class--- import Control.Monad.IO.Control-import Control.Monad.Trans.Control-import Control.Applicative-import Control.Concurrent-import Control.DeepSeq-import qualified Control.Exception.Lifted as E-import Control.Exception.Base-import qualified Control.Concurrent.Thread as Thread ( forkIO )-import Data.Time.LocalTime-import qualified Data.Binary as Bin-import System.Directory+import           Control.Applicative+import           Control.Concurrent+import qualified Control.Concurrent.Thread    as Thread ( forkIO )+import           Control.DeepSeq+import           Control.Exception.Base+import qualified Control.Exception.Lifted     as E+import           Control.Monad+import           Control.Monad.IO.Class+import           Control.Monad.Trans.Control+import qualified Data.Binary                  as Bin+import           Data.Time.LocalTime+import           System.Directory -import Debug.Trace (trace)+import           Debug.Trace                  (trace)  -- Quasi-quotation syntax changed from GHC 6 to 7, -- so we need this switch in order to support both@@ -134,11 +125,14 @@     yesod <- getYesod     liftIO $ modifyMVar (theoryVar yesod) $ \theories -> do       time <- getZonedTime-      let idx = if M.null theories then 1 else fst (M.findMax theories) + 1-          parentIdx = tiIndex <$> parent+      let idx | M.null theories = 1+              | otherwise       = fst (M.findMax theories) + 1+          parentIdx    = tiIndex <$> parent           parentOrigin = tiOrigin <$> parent-          newOrigin = parentOrigin <|> origin <|> (Just Interactive)-          newThy = TheoryInfo idx thy time parentIdx False (fromJust newOrigin)+          newOrigin    = parentOrigin <|> origin <|> (Just Interactive)+          newThy       =+              TheoryInfo idx thy time parentIdx False (fromJust newOrigin)+                         (maybe (defaultAutoProver yesod) tiAutoProver parent)       storeTheory yesod newThy idx       return (M.insert idx newThy theories, idx) @@ -224,7 +218,7 @@  -- | Print exceptions, if they happen. traceExceptions :: MonadBaseControl IO m => String -> m a -> m a-traceExceptions info = +traceExceptions info =     E.handle handler   where     handler :: MonadBaseControl IO m => E.SomeException -> m a@@ -245,8 +239,8 @@     go (JsonHtml title content) = object       [ "html"  .= contentToJson content       , "title" .= title ]-    -    contentToJson (ContentBuilder b _) = toJSON $ B.toLazyByteString b ++    contentToJson (ContentBuilder b _) = toJSON $ B.toLazyByteString b     contentToJson _ = error "Unsupported content format in json response!"  -- | Fully evaluate a value in a thread that can be canceled.@@ -395,9 +389,11 @@     -- Handle method paths by trying to solve the given goal/method     --     go _ (TheoryMethod lemma proofPath i) ti = modifyTheory ti-      (\thy -> return $ applyMethodAtPath thy lemma proofPath i)-      (\thy -> nextSmartThyPath thy (TheoryProof lemma proofPath))-      (JsonAlert "Sorry, but the prover failed on the selected method!")+        (\thy -> return $ applyMethodAtPath thy lemma proofPath heuristic i)+        (\thy -> nextSmartThyPath thy (TheoryProof lemma proofPath))+        (JsonAlert "Sorry, but the prover failed on the selected method!")+      where+        heuristic = apHeuristic (tiAutoProver ti)      --     -- Handle generic paths by trying to render them@@ -414,10 +410,12 @@     return $ RepJson $ toContent jsonValue   where     go (TheoryProof lemma proofPath) ti = modifyTheory ti-      (\thy -> -          return $ applyProverAtPath thy lemma proofPath (mapProverProof cutOnAttackDFS autoProver))-      (\thy -> nextSmartThyPath thy path)-      (JsonAlert "Sorry, but the autoprover failed on given proof step!")+        (\thy ->+            return $ applyProverAtPath thy lemma proofPath autoProver)+        (\thy -> nextSmartThyPath thy path)+        (JsonAlert "Sorry, but the autoprover failed on given proof step!")+      where+        autoProver = runAutoProver (tiAutoProver ti)      go _ _ = return . responseToJson $ JsonAlert       "Can't run autoprover on the given theory path!"@@ -464,9 +462,9 @@       sendFile (fromString . imageFormatMIME $ imageFormat yesod) img   where     graphStyle d c = dotStyle d . compression c-    dotStyle True = dotSequentCompact CompactBoringNodes-    dotStyle False = dotSequentCompact FullBoringNodes-    compression True = compressSequent+    dotStyle True = dotSystemCompact CompactBoringNodes+    dotStyle False = dotSystemCompact FullBoringNodes+    compression True = compressSystem     compression False = id  @@ -547,7 +545,7 @@       , T.pack $ show err ]      name = T.pack . get thyName . tiTheory-    theoryFormTpl = formTpl (EditTheoryR idx) "Load as new theory" +    theoryFormTpl = formTpl (EditTheoryR idx) "Load as new theory" -}  {-@@ -575,7 +573,7 @@               let openThy  = openTheory thy                   openThy' = case lemma of                     Nothing -> addLemma newLemma openThy-                    Just _  -> removeLemma lemmaName openThy +                    Just _  -> removeLemma lemmaName openThy                                   >>= addLemma newLemma               traverse (closeThy yesod) openThy')             -- Error response@@ -615,7 +613,7 @@       (JsonAlert "Sorry, but removing the selected lemma failed!")      go (TheoryProof lemma proofPath) ti = modifyTheory ti-      (\thy -> return $ +      (\thy -> return $           applyProverAtPath thy lemma proofPath (sorryProver "removed"))       (const path)       (JsonAlert "Sorry, but removing the selected proof step failed!")@@ -659,7 +657,7 @@ -- | Unload a theory from the interactive server. getUnloadTheoryR :: TheoryIdx -> Handler RepPlain getUnloadTheoryR idx = do-    delTheory idx +    delTheory idx     redirect RootR  {-
src/Web/Instances.hs view
@@ -12,16 +12,14 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Web.Instances where -import Data.DeriveTH-import Data.Binary+import           Data.Binary+import           Data.DeriveTH -import Web.Types-import Data.Time.Calendar-import Data.Time.LocalTime-import Data.Fixed-import Data.Set ()-import Data.Map ()-import Control.DeepSeq+import           Control.DeepSeq+import           Data.Fixed+import           Data.Time.Calendar+import           Data.Time.LocalTime+import           Web.Types  $( derive makeBinary ''TheoryOrigin) $( derive makeBinary ''TheoryInfo)
src/Web/Theory.hs view
@@ -1,16 +1,15 @@+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE TupleSections #-} {- | Module      :  Web.Theory Description :  Pretty-printing security protocol theories into HTML code. Copyright   :  (c) 2011, 2012 Simon Meier & Cedric Staub License     :  GPL-3 -Maintainer  :  Cedric Staub <cstaub@ethz.ch>+Maintainer  :  Simon Meier <iridcode@gmail.com> Stability   :  experimental Portability :  non-portable -}--{-# LANGUAGE PatternGuards, TupleSections #-}- module Web.Theory   ( htmlThyPath --  , htmlThyDbgPath@@ -27,68 +26,60 @@   ) where -import Theory-import Theory.Pretty+import           Data.List+import qualified Data.Map              as M+import           Data.Maybe+import           Data.Monoid+import qualified Data.Text             as T -import Web.Types-import Web.Settings+import           Control.Basics -import Data.Maybe-import Data.List-import Data.Monoid-import qualified Data.Map as M-import qualified Data.Text as T+import           System.Directory+import           System.FilePath -import Control.Basics+import           Extension.Data.Label -import System.Directory-import System.FilePath+import qualified Text.Dot              as D+import           Text.PrettyPrint.Html+import           Utils.Misc            (stringSHA256) -import Extension.Data.Label+import           System.Exit+import           System.Process -import qualified Text.Dot as D-import Text.PrettyPrint.Html-import Utils.Misc (stringSHA256)+import           Logic.Connectives+import           Theory+import           Theory.Text.Pretty -import System.Process-import System.Exit+import           Web.Settings+import           Web.Types + ------------------------------------------------------------------------------ -- Various other functions ------------------------------------------------------------------------------ --- | Extract and simplify a proof of a lemma for presentation.-extractSimplifiedLemmaProof :: Lemma IncrementalProof -> IncrementalProof-extractSimplifiedLemmaProof =-  -- Simplify variable indices just before displaying. This addresses #27.-  -- Due to lazy-evaluation the effort is linear in the proof depth. This is-  -- probably OK. Note that this implies that the displayed terms and the-  -- stored terms do not agree. This is no problem for paths, as they use-  -- relative addressing anyways.-    fmap dropMayLoop . simplifyVariableIndices . get lProof-  where-    dropMayLoop (ProofStep (SolveGoal (PremiseG p fa _)) info) =-        ProofStep (SolveGoal (PremiseG p fa False)) info-    dropMayLoop step = step- checkProofs :: ClosedTheory -> ClosedTheory checkProofs = proveTheory checkedProver   where     checkedProver = checkAndExtendProver (sorryProver "not yet proven")  applyMethodAtPath :: ClosedTheory -> String -> ProofPath-                  -> Int -> Maybe ClosedTheory-applyMethodAtPath thy lemmaName proofPath i = do+                  -> Heuristic             -- ^ How to extract/order the proof methods.+                  -> Int                   -- What proof method to use.+                  -> Maybe ClosedTheory+applyMethodAtPath thy lemmaName proofPath heuristic i = do     lemma <- lookupLemma lemmaName thy     subProof <- get lProof lemma `atPath` proofPath-    let ctxt = getProofContext lemma thy-    methods <- applicableProofMethods ctxt <$> psInfo (root subProof)+    let ctxt  = getProofContext lemma thy+        sys   = psInfo (root subProof)+        ranking = useHeuristic heuristic (length proofPath)+    methods <- (map fst . rankProofMethods ranking ctxt) <$> sys     method <- if length methods >= i then Just (methods !! (i-1)) else Nothing-    applyProverAtPath thy lemmaName proofPath -      (oneStepProver method `mappend` +    applyProverAtPath thy lemmaName proofPath+      (oneStepProver method                        `mappend`        replaceSorryProver (oneStepProver Simplify) `mappend`-       replaceSorryProver (contradictionAndClauseProver) `mappend`-       replaceSorryProver (oneStepProver Attack)+       replaceSorryProver (contradictionProver)    `mappend`+       replaceSorryProver (oneStepProver Solved)       )  applyProverAtPath :: ClosedTheory -> String -> ProofPath@@ -96,6 +87,7 @@ applyProverAtPath thy lemmaName proofPath prover =     modifyLemmaProof (focus proofPath prover) lemmaName thy + ------------------------------------------------------------------------------ -- Pretty printing ------------------------------------------------------------------------------@@ -131,7 +123,7 @@ proofIndex :: HtmlDocument d            => RenderUrl            -> (ProofPath -> Route WebUI)         -- ^ Relative addressing function-           -> Proof (Maybe Sequent, Maybe Bool) -- ^ The annotated incremental proof+           -> Proof (Maybe System, Maybe Bool) -- ^ The annotated incremental proof            -> d proofIndex renderUrl mkRoute =     prettyProofWith ppStep ppCase . insertPaths@@ -176,7 +168,7 @@     proofIndex renderUrl mkRoute annPrf   where     editPng = png "/static/img/edit.png"-    deletePng = png "/static/img/delete.png" +    deletePng = png "/static/img/delete.png"     png path = closedTag "img" [("class","icon"),("src",path)]      annPrf = annotateLemmaProof l@@ -208,13 +200,13 @@     rulesInfo      = parens $ int $ length $ get crProtocol rules     casesInfo kind =         parens $ nCases <> comma <-> text chainInfo-      where +      where         cases   = getCaseDistinction kind thy         nChains = sum $ map (sum . unsolvedChainConstraints) cases         nCases  = int (length cases) <-> text "cases"         chainInfo | nChains == 0 = "all chains solved"                   | otherwise    = show nChains ++ " chains left"-         +     bold                = withTag "strong" [] . text     overview n info p   = linkToPath renderUrl (TheoryPathMR tidx p) [] (bold n <-> info)     messageLink         = overview "Message theory" (text "") TheoryMessage@@ -225,10 +217,10 @@ -- | A snippet that explains a sequent using a rendered graph and the pretty -- printed sequent. sequentSnippet :: HtmlDocument d-               => Sequent     -- ^ Sequent to pretty print.+               => System     -- ^ System to pretty print.                -> TheoryPath  -- ^ The sequents path (NOT the path to its PNG)                -> d-sequentSnippet se path = refDotPath path $-$ preformatted Nothing (prettySequent se)+sequentSnippet se path = refDotPath path $-$ preformatted Nothing (prettySystem se) -}  -- | A snippet that explains a sub-proof by displaying its proof state, the@@ -238,10 +230,11 @@                 -> TheoryIdx                 -- ^ The theory index.                 -> String                    -- ^ The lemma.                 -> ProofPath                 -- ^ The proof path.+                -> Heuristic                 -- ^ The heuristic to use.                 -> ProofContext              -- ^ The proof context.                 -> IncrementalProof          -- ^ The sub-proof.                 -> d-subProofSnippet renderUrl tidx lemma proofPath ctxt prf =+subProofSnippet renderUrl tidx lemma proofPath heuristic ctxt prf =     case psInfo $ root prf of       Nothing -> text $ "no annotated constraint system / " ++ nCases ++ " sub-case(s)"       Just se -> vcat $@@ -256,38 +249,44 @@          else [ withTag "h3" [] (text "Constraint System has no Graph Part") ])         ++         [ withTag "h3" [] (text "Pretty-Printed Constraint System")-        , preformatted (Just "sequent") (prettyNonGraphSequent se)+        , preformatted (Just "sequent") (prettyNonGraphSystem se)         , withTag "h3" [] (text $ nCases ++ " sub-case(s)")-        ] ++ +        ] ++         subCases   where-    prettyApplicableProofMethods se = case proofMethods se of+    prettyApplicableProofMethods sys = case proofMethods sys of         []  -> [ withTag "h3" [] (text "Constraint System is Solved") ]-        pms -> [ withTag "h3" [] (text "Applicable Proof Methods")-               , preformatted (Just "methods") (numbered' $ map prettyPM $ zip [1..] pms)-               , text "a." <-> -                 linkToPath renderUrl (AutoProverR tidx (TheoryProof lemma proofPath))-                     ["autoprove"] (keyword_ "autoprove")-               ]+        pms ->+          [ withTag "h3" [] (text "Applicable Proof Methods:" <->+                             comment_ (goalRankingName ranking))+          , preformatted (Just "methods") (numbered' $ map prettyPM $ zip [1..] pms)+          , text "a." <->+            linkToPath renderUrl (AutoProverR tidx (TheoryProof lemma proofPath))+                ["autoprove"] (keyword_ "autoprove")+          ] -    prettyPM (i, m) = linkToPath renderUrl-      (TheoryPathMR tidx (TheoryMethod lemma proofPath i))-      ["proof-method"] (prettyProofMethod m)+    prettyPM (i, (m, (_cases, expl))) =+      linkToPath renderUrl+        (TheoryPathMR tidx (TheoryMethod lemma proofPath i))+        ["proof-method"] (prettyProofMethod m)+      <-> (if null expl then emptyDoc else lineComment_ expl) -    nCases   = show $ M.size $ children prf-    hasGraphPart se = not $ M.empty == get sNodes se-    proofMethods = applicableProofMethods ctxt-    subCases = concatMap refSubCase $ M.toList $ children prf -    refSubCase (name, prf') = +    nCases                  = show $ M.size $ children prf+    hasGraphPart se         = not $ M.empty == get sNodes se+    depth                   = length proofPath+    ranking                 = useHeuristic heuristic depth+    proofMethods            = rankProofMethods ranking ctxt+    subCases                = concatMap refSubCase $ M.toList $ children prf+    refSubCase (name, prf') =         [ withTag "h4" [] (text "Case" <-> text name)         , maybe (text "no proof state available")                 (const $ refDotPath renderUrl tidx $ TheoryProof lemma (proofPath ++ [name]))-                (psInfo $ root prf') +                (psInfo $ root prf')         ]   -- | A Html document representing the requires case splitting theorem.-htmlCaseDistinction :: HtmlDocument d +htmlCaseDistinction :: HtmlDocument d                     => RenderUrl -> TheoryIdx -> CaseDistKind -> (Int, CaseDistinction) -> d htmlCaseDistinction renderUrl tidx kind (j, th) =     if null cases@@ -297,17 +296,17 @@     cases    = concatMap ppCase $ zip [1..] $ getDisj $ get cdCases th     wrapP    = withTag "p" [("class","monospace cases")]     nCases   = int $ length $ getDisj $ get cdCases th-    ppPrem   = nest 2 $ doubleQuotes $ prettyLNFact $ get cdGoal th-    ppHeader = hsep +    ppPrem   = nest 2 $ doubleQuotes $ prettyGoal $ get cdGoal th+    ppHeader = hsep       [ text "Sources of" <-> ppPrem       , parens $ nCases <-> text "cases"       ]-    ppCase (i, (names, (conc, se))) = +    ppCase (i, (names, se)) =       [ withTag "h3" [] $ fsep [ text "Source", int i, text "of", nCases                                , text " / named ", doubleQuotes (text name) ]       , refDotPath renderUrl tidx (TheoryCaseDist kind j i)-      , withTag "p" [] $ ppPrem <-> text "provided by conclusion" <-> prettyNodeConc conc-      , wrapP $ prettyNonGraphSequent se+      , withTag "p" [] $ ppPrem+      , wrapP $ prettyNonGraphSystem se       ]       where         name = intercalate "_" names@@ -321,7 +320,7 @@ rulesSnippet :: HtmlDocument d => ClosedTheory -> d rulesSnippet thy = vcat     [ ppRules "Multiset Rewriting Rules"      crProtocol-    ] +    ]   where     rules = getClassifiedRules thy     ppRules header l =@@ -355,11 +354,12 @@     go TheoryRules               = rulesSnippet thy     go TheoryMessage             = messageSnippet thy     go (TheoryCaseDist kind _ _) = reqCasesSnippet renderUrl tidx kind thy-    go (TheoryProof l p)         = +    go (TheoryProof l p)         =         fromMaybe (text "No such lemma or proof path.") $ do            lemma <- lookupLemma l thy-           let ctxt = getProofContext lemma thy-           subProofSnippet renderUrl tidx l p ctxt+           let ctxt      = getProofContext lemma thy+               heuristic = apHeuristic $ tiAutoProver ti+           subProofSnippet renderUrl tidx l p heuristic ctxt              <$> resolveProofPath thy l p     go (TheoryLemma _)      = text "Implement theory item pretty printing!"     go _                    = text "Unhandled theory path. This is a bug."@@ -377,22 +377,22 @@   where     go (TheoryProof l p) = do       proof <- resolveProofPath thy l p-      prettySequent <$> psInfo (root proof)+      prettySystem <$> psInfo (root proof)     go _ = Nothing -}  -- | Render the image corresponding to the given theory path.-imgThyPath :: ImageFormat -> FilePath -> FilePath -> (Sequent -> D.Dot ()) -> ClosedTheory+imgThyPath :: ImageFormat -> FilePath -> FilePath -> (System -> D.Dot ()) -> ClosedTheory            -> TheoryPath -> IO FilePath imgThyPath imgFormat dotCommand dir compact thy path = go path   where     go (TheoryCaseDist k i j) = renderDotCode (casesDotCode k i j)     go (TheoryProof l p)      = renderDotCode (proofPathDotCode l p)     go _                      = error "Unhandled theory path. This is a bug."-    +     -- Get dot code for required cases     casesDotCode k i j = D.showDot $-        compact $ snd $ snd $ cases !! (i-1) !! (j-1)+        compact $ snd $ cases !! (i-1) !! (j-1)       where         cases = map (getDisj . get cdCases) (getCaseDistinction k thy) @@ -432,7 +432,7 @@   -- | Get title to display for a given proof path.-titleThyPath :: ClosedTheory -> TheoryPath -> String +titleThyPath :: ClosedTheory -> TheoryPath -> String titleThyPath thy path = go path   where     go TheoryRules                          = "Rewriting rules"@@ -442,7 +442,7 @@     go (TheoryLemma l)                      = "Lemma: " ++ l     go (TheoryProof l [])                   = "Lemma: " ++ l     go (TheoryProof l p)-      | null (last p)       = "Method: " ++ methodName l p +      | null (last p)       = "Method: " ++ methodName l p       | otherwise           = "Case: " ++ last p     go _ = "Unhandled theory path" @@ -458,7 +458,7 @@                  -> Maybe IncrementalProof resolveProofPath thy lemmaName path = do   lemma <- lookupLemma lemmaName thy-  extractSimplifiedLemmaProof lemma `atPath` path+  get lProof lemma `atPath` path   ------------------------------------------------------------------------------@@ -520,13 +520,11 @@      getPrevLemma lemmaName = getPrevElement (== lemmaName) (map fst lemmas) -- -- | Interesting proof methods that are not skipped by next/prev-smart. isInterestingMethod :: ProofMethod -> Bool isInterestingMethod (Sorry _) = True-isInterestingMethod m         = m == Attack-+isInterestingMethod Solved    = True+isInterestingMethod _         = False  -- Get 'next' smart theory path. nextSmartThyPath :: ClosedTheory -> TheoryPath -> TheoryPath@@ -634,12 +632,12 @@ -- The boolean flag indicates that the given proof step's children -- are (a) all annotated and (b) contain no sorry steps. annotateLemmaProof :: Lemma IncrementalProof-                   -> Proof (Maybe Sequent, Maybe Bool)-annotateLemmaProof lem = +                   -> Proof (Maybe System, Maybe Bool)+annotateLemmaProof lem =     mapProofInfo (second interpret) prf   where-    prf = annotateProof annotate $ extractSimplifiedLemmaProof lem-    annotate step cs = +    prf = annotateProof annotate $ get lProof lem+    annotate step cs =         ( psInfo step         , mconcat $ proofStepStatus step : incomplete ++ map snd cs         )@@ -681,16 +679,16 @@  $(mkLabels [''ThHtmlState]) -type ThHtml = ReaderT (Sequent -> Sequent) (StateT ThHtmlState Fresh)+type ThHtml = ReaderT (System -> System) (StateT ThHtmlState Fresh) -runThHtml :: (Sequent -> Sequent) -> ThHtml a -> (a, ThHtmlState)-runThHtml compress = -    (`evalFresh` nothingUsed) -  . (`runStateT` emptyThHtmlState) +runThHtml :: (System -> System) -> ThHtml a -> (a, ThHtmlState)+runThHtml compress =+    (`evalFresh` nothingUsed)+  . (`runStateT` emptyThHtmlState)   . (`runReaderT` compress)  instance JSON Viewport where-        readJSON (JSString name) = case fromJSString name of +        readJSON (JSString name) = case fromJSString name of             "Left"  -> return LeftView             "Main"  -> return MainView             "Debug" -> return DebugView@@ -742,8 +740,8 @@       , filesDir        = "files"       } -    extendBaseName ext = -      filesDir info </> +    extendBaseName ext =+      filesDir info </>       addExtension (takeBaseName (giInputFile input) ++ ext) "spthy"  -- | Make a path that is specified relative to the output directory absolute.@@ -767,8 +765,8 @@     , ("inputFile",   showJSON . fileLink   $ inputFileCopy paths)     , ("proofScript", showJSON . fileLink   $ proofScriptFile paths)     , ("commandLine", showJSON . toJSString $ giCmdLine input)-    , ("certificateStatus", showJSON . toJSString $ genTimeString) -    ] +    , ("certificateStatus", showJSON . toJSString $ genTimeString)+    ]   where     paths = pathInfo input     fileLink file = (toJSString (takeFileName file), toJSString file)@@ -784,7 +782,7 @@     copyFile (giInputFile input) (mkAbsolute paths $ inputFileCopy paths)     -- timed proof script generation     putStr " generating proof script: " >> hFlush stdout-    genTime <- timed_ $ writeAbsolute (proofScriptFile paths) +    genTime <- timed_ $ writeAbsolute (proofScriptFile paths)                           (render $ prettyClosedTheory $ giTheory input)     putStrLn $ show genTime     -- json output@@ -798,7 +796,7 @@     paths = pathInfo input     writeAbsolute = writeFile . mkAbsolute paths -    compress | giCompress input = compressSequent+    compress | giCompress input = compressSystem              | otherwise        = id      (thId, thSt) = runThHtml compress $ do@@ -819,20 +817,20 @@     mkGraph (path, dotCode) msgChan = do       let outFile = mkAbsolute paths path           pngFile = addExtension outFile "png"-      ifM (doesFileExist pngFile) -          (writeChan msgChan $ "using cached file: " ++ pngFile) +      ifM (doesFileExist pngFile)+          (writeChan msgChan $ "using cached file: " ++ pngFile)           (do writeFile outFile dotCode               graphvizDotToPng outFile pngFile msgChan               removeFile outFile)      -- | Convert a list of dot strings in parallel to png files, using the number of     -- cores+1 parallel executions of the dot tool.-    parMkGraphs = +    parMkGraphs =         parCmd_ display . map mkGraph       where-        display n i msg = +        display n i msg =             hPutStrLn stdout $ "  ["++showPadded i++" of "++show n++"] "++msg-          where +          where             showPadded x = flushRight (length (show n)) (show x)  -- | Copy all the files referenced in the template index file to the output
src/Web/Types.hs view
@@ -36,28 +36,28 @@   -- Image rendering   , ImageFormat(..)   , imageFormatMIME-  ) +  ) where -import Theory+import           Theory -import Yesod.Core-import Yesod.Static+import           Yesod.Core+import           Yesod.Static -import Text.Hamlet+import           Text.Hamlet -import Data.Monoid (mconcat)-import Data.Maybe (listToMaybe)-import Data.Ord (comparing)-import Data.Time.LocalTime-import Data.Label-import Control.Concurrent+import           Control.Concurrent+import           Data.Label+import           Data.Maybe          (listToMaybe)+import           Data.Monoid         (mconcat)+import           Data.Ord            (comparing)+import           Data.Time.LocalTime -import qualified Data.Map as M-import qualified Data.Text as T+import qualified Data.Map            as M+import qualified Data.Text           as T  -- import Control.Monad.IO.Class-import Control.Applicative+import           Control.Applicative  ------------------------------------------------------------------------------ -- Types@@ -93,7 +93,7 @@ imageFormatMIME SVG = "image/svg+xml"  -- | The so-called site argument for our application, which can hold various--- information that can use to keep info that needs to be available to the +-- information that can use to keep info that needs to be available to the -- handler functions. data WebUI = WebUI   { getStatic   :: Static@@ -115,6 +115,8 @@     -- ^ The dot command   , imageFormat :: ImageFormat     -- ^ The image-format used for rendering graphs+  , defaultAutoProver :: AutoProver+    -- ^ The default prover to use for automatic proving.   , debug :: Bool     -- ^ Output debug messages   }@@ -131,16 +133,17 @@ data TheoryOrigin = Local FilePath | Upload String | Interactive      deriving (Show, Eq, Ord) --- | Data type containg both the theory and it's index, making it easier to +-- | Data type containg both the theory and it's index, making it easier to -- pass the two around (since they are always tied to each other). We also -- keep some extra bookkeeping information. data TheoryInfo = TheoryInfo-  { tiIndex     :: TheoryIdx       -- ^ Index of theory.-  , tiTheory    :: ClosedTheory    -- ^ The closed theory.-  , tiTime      :: ZonedTime       -- ^ Time theory was loaded.-  , tiParent    :: Maybe TheoryIdx -- ^ Prev theory in history-  , tiPrimary   :: Bool            -- ^ This is the orginally loaded theory.-  , tiOrigin    :: TheoryOrigin    -- ^ Origin of theory.+  { tiIndex      :: TheoryIdx       -- ^ Index of theory.+  , tiTheory     :: ClosedTheory    -- ^ The closed theory.+  , tiTime       :: ZonedTime       -- ^ Time theory was loaded.+  , tiParent     :: Maybe TheoryIdx -- ^ Prev theory in history+  , tiPrimary    :: Bool            -- ^ This is the orginally loaded theory.+  , tiOrigin     :: TheoryOrigin    -- ^ Origin of theory.+  , tiAutoProver :: AutoProver      -- ^ The automatic prover to use.   }  -- | We use the ordering in order to display loaded theories to the user.@@ -148,7 +151,7 @@ -- that were loaded from the command-line are displayed earlier then -- interactively loaded ones. compareTI :: TheoryInfo -> TheoryInfo -> Ordering-compareTI (TheoryInfo _ i1 t1 p1 a1 o1) (TheoryInfo _ i2 t2 p2 a2 o2) =+compareTI (TheoryInfo _ i1 t1 p1 a1 o1 _) (TheoryInfo _ i2 t2 p2 a2 o2 _) =   mconcat     [ comparing (get thyName) i1 i2     , comparing zonedTimeToUTC t1 t2@@ -181,7 +184,7 @@   = TheoryHelp                          -- ^ The help view (help and info about theory)   | TheoryLemma String                  -- ^ Theory lemma with given name   | TheoryIntrVar Int                   -- ^ Intruder variant (n'th from start)-  | TheoryCaseDist CaseDistKind Int Int -- ^ Required cases (i'th source, j'th case) +  | TheoryCaseDist CaseDistKind Int Int -- ^ Required cases (i'th source, j'th case)   | TheoryProof String ProofPath        -- ^ Proof path within proof for given lemma   | TheoryMethod String ProofPath Int   -- ^ Apply the proof method to proof path   | TheoryRules                         -- ^ Theory rules@@ -211,14 +214,14 @@   "variant" -> parseVariant xs   "proof"   -> parseProof xs   "method"  -> parseMethod xs-  _         -> Nothing +  _         -> Nothing   where     safeRead = listToMaybe . map fst . reads      parseLemma ys = TheoryLemma <$> listToMaybe ys      parseProof (y:ys) = Just (TheoryProof y ys)-    parseProof _      = Nothing +    parseProof _      = Nothing      parseMethod (y:z:zs) = safeRead z >>= Just . TheoryMethod y zs     parseMethod _        = Nothing@@ -227,7 +230,7 @@     parseVariant _     = Nothing      parseCases (kind:y:z:_) = do-      k <- case kind of "typed"   -> return TypedCaseDist +      k <- case kind of "typed"   -> return TypedCaseDist                         "untyped" -> return UntypedCaseDist                         _         -> Nothing       m <- safeRead y@@ -315,7 +318,7 @@ -- | Our application's default layout template. -- Note: We define the default layout here even tough it doesn't really -- belong in the "types" module in order to avoid mutually recursive modules.--- defaultLayout' :: (Yesod master, Route master ~ WebUIRoute) +-- defaultLayout' :: (Yesod master, Route master ~ WebUIRoute) --                => GWidget sub master ()      -- ^ Widget to embed in layout --                -> GHandler sub master RepHtml defaultLayout' :: Yesod master =>
tamarin-prover.cabal view
@@ -1,7 +1,7 @@ cabal-version:      >= 1.8 build-type:         Simple name:               tamarin-prover-version:            0.4.1.0+version:            0.6.0.0 license:            GPL license-file:       LICENSE category:           Theorem Provers@@ -10,7 +10,7 @@ maintainer:         Simon Meier <simon.meier@inf.ethz.ch> copyright:          Benedikt Schmidt, Simon Meier, ETH Zurich, 2010-2012 synopsis:           The Tamarin prover for security protocol analysis.-description:        +description:      The Tamarin prover is a tool for the analysis of security protocols. It     implements a constraint solving algorithm that supports both falsification@@ -67,11 +67,25 @@   -- documentation   doc/MANUAL -  -- example files-  examples/stable/Tutorial.spthy-  examples/stable/TLS.spthy-  examples/stable/InvariantsExample.spthy+  -- examples files+  examples/Tutorial.spthy +  -- classic security protocols+  examples/classic/TLS_Handshake.spthy+  examples/classic/NSLPK3.spthy++  -- loops+  examples/loops/Minimal_Crypto_API.spthy+  examples/loops/Minimal_KeyRenegotiation.spthy+  examples/loops/Minimal_Create_Use_Destroy.spthy+  examples/loops/TESLA_Scheme1.spthy++  -- related work+  examples/related_work/AIF_Moedersheim_CCS10/Keyserver.spthy+  examples/related_work/StatVerif_ARR_CSF11/StatVerif_Example1.spthy+  examples/related_work/TPM_DKRS_CSF11/Envelope.spthy+  examples/related_work/TPM_DKRS_CSF11/RunningExample.spthy+   -- CSF'12 case studies   examples/csf12/Artificial.spthy @@ -158,19 +172,19 @@         , blaze-html        == 0.4.*         , http-types        == 0.6.*         , blaze-builder     == 0.3.*-        , yesod-core        == 0.10.*-        , yesod-json        == 0.3.*-        , yesod-static      == 0.10.*+        , yesod-core        == 1.0.*+        , yesod-json        == 1.0.*+        , yesod-static      == 1.0.*         -- , yesod-form        == 0.4.*   -- required once we reactivate editing         , text              == 0.11.*-        , wai               == 1.1.*-        , hamlet            == 0.10.*-        , warp              == 1.1.*+        , wai               == 1.2.*+        , hamlet            == 1.0.*+        , warp              == 1.2.*         , aeson             == 0.6.*         , old-locale        == 1.0.*         , monad-control     == 0.3.*-        , lifted-base-        , threads           == 0.4.*+        , lifted-base       == 0.1.*+        , threads           >= 0.4 && < 0.6      build-depends:         base              == 4.*@@ -195,51 +209,69 @@       , parallel          == 3.2.*       , HUnit             == 1.2.* -      , tamarin-prover-utils == 0.4.1.*-      , tamarin-prover-term  == 0.4.1.*+      , tamarin-prover-utils == 0.6.*+      , tamarin-prover-term  == 0.6.*       other-modules:       Paths_tamarin_prover-      Main_NoGui++      Main       Main_Full+      Main_NoGui       Main.Console       Main.Environment       Main.TheoryLoader       Main.Utils-      Main.Mode.Test       Main.Mode.Batch-      Main.Mode.Intruder       Main.Mode.Interactive+      Main.Mode.Intruder+      Main.Mode.Test -      Theory.AbstractInterpretation-      Theory.Pretty-      Theory.Fact-      Theory.Atom-      Theory.Formula-      Theory.Rule-      Theory.IntruderRules-      Theory.Proof.Guarded-      Theory.Proof.Types-      Theory.Proof.EquationStore-      Theory.Proof.SolveGuarded-      Theory.Proof.Sequent-      Theory.Proof.Sequent.Dot-      Theory.Proof.CaseDistinctions-      Theory.Proof-      Theory.RuleVariants-      Theory.RuleSet-      Theory.Signature       Theory-      Theory.Lexer-      Theory.Parser-      Theory.Wellformedness+      Theory.Proof -      Web.Settings-      Web.Types-      Web.Theory+      Theory.Constraint.Solver+      Theory.Constraint.Solver.CaseDistinctions+      Theory.Constraint.Solver.Contradictions+      Theory.Constraint.Solver.Goals+      Theory.Constraint.Solver.Reduction+      Theory.Constraint.Solver.Simplify+      Theory.Constraint.Solver.ProofMethod+      Theory.Constraint.Solver.Types+      Theory.Constraint.System+      Theory.Constraint.System.Dot+      Theory.Constraint.System.Guarded+      Theory.Constraint.System.Constraints++      Theory.Model+      Theory.Model.Atom+      Theory.Model.Fact+      Theory.Model.Formula+      Theory.Model.Rule+      Theory.Model.Signature++      Theory.Text.Lexer+      Theory.Text.Parser+      Theory.Text.Pretty++      Theory.Tools.AbstractInterpretation+      Theory.Tools.IntruderRules+      Theory.Tools.LoopBreakers+      Theory.Tools.RuleVariants+      Theory.Tools.Wellformedness+      Theory.Tools.EquationStore+      Theory.Tools.UniqueFactInstances++      Web.Dispatch       Web.Hamlet-      Web.Instances       Web.Handler-      Web.Dispatch+      Web.Instances+      Web.Settings+      Web.Theory+      Web.Types++source-repository head+  type:     git+  location: https://github.com/tamarin-prover/tamarin-prover.git