├── .classpath ├── .gitignore ├── .project ├── .travis.yml ├── LICENSE ├── README.md ├── dev └── user.clj ├── logos ├── funnyqt.pdf ├── funnyqt.png ├── funnyqt.svg ├── icon16.png └── icon32.png ├── make-and-upload-docs.sh ├── project.clj ├── resources ├── check16.png ├── cross16.png ├── pattern-schema.tg ├── state-space-schema.tg ├── xml-schema.pdf ├── xml-schema.png └── xml-schema.tg ├── src └── funnyqt │ ├── bidi.clj │ ├── bidi │ └── internal.clj │ ├── coevo │ └── tg.clj │ ├── edn.clj │ ├── emf.clj │ ├── extensional.clj │ ├── generic.clj │ ├── in_place.clj │ ├── internal.clj │ ├── model2model.clj │ ├── pmatch.clj │ ├── polyfns.clj │ ├── query.clj │ ├── query │ ├── emf.clj │ └── tg.clj │ ├── relational.clj │ ├── relational │ ├── tmp_elem.clj │ └── util.clj │ ├── tg.clj │ ├── utils.clj │ ├── visualization.clj │ └── xmltg.clj └── test ├── funnyqt ├── bidi_test.clj ├── coevo │ └── tg_test.clj ├── edn_test.clj ├── emf_test.clj ├── extensional_test.clj ├── in_place │ ├── emf_test.clj │ └── tg_test.clj ├── in_place_test.clj ├── misc_tests │ ├── classhierarchy2documents.clj │ ├── mutual_exclusion_emf.clj │ ├── mutual_exclusion_tg.clj │ ├── sierpinski_tg.clj │ └── tree_tg.clj ├── model2model_test.clj ├── pmatch_test.clj ├── polyfns_test.clj ├── query │ ├── emf_test.clj │ └── tg_test.clj ├── query_test.clj ├── relational │ ├── emf_test.clj │ └── tg_test.clj ├── tg_test.clj ├── utils_test.clj └── xmltg_test.clj ├── input ├── AddressBook.ecore ├── Families.ecore ├── Genealogy.ecore ├── MutualExclusion.ecore ├── PMatchTestMetamodel.ecore ├── PMatchTestSchema.tg ├── addressbook.tg ├── binop-tree-schema.tg ├── cd2db-simple │ ├── cd-schema.tg │ └── db-schema.tg ├── classhierarchy.tg ├── clock.ecore ├── component-schema-v1.tg ├── counter-schema.tg ├── documents.tg ├── dup-roles-graph.tg ├── example.families ├── familygraph.tg ├── firm_medium_1248803056.tg ├── firm_small_46.tg ├── genealogy-schema.tg ├── greqltestgraph.tg ├── jdk-jex.tg.gz ├── medium-model.tg ├── mintree-schema.tg ├── mutual-exclusion-schema.tg ├── polyfntestschema.tg ├── sierpinski-schema.tg ├── uml-rdbms-bidi │ ├── classdiagram.ecore │ ├── classdiagram.ecorediag │ ├── database.ecore │ ├── database.ecorediag │ ├── m1 │ │ └── classdiagram01.xmi │ └── m2 │ │ └── database01.xmi ├── xml-example-with-semantically-important-text.xml ├── xmltg-example-with-dtd-and-IDREFS.xml ├── xmltg-example-with-dtd.xml └── xmltg-example-without-dtd.xml └── output └── .keep /.classpath: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .lein* 2 | lib/ 3 | classes/ 4 | docs/ 5 | pom.xml 6 | html5-docs.log 7 | funnyqt-?.?.?.jar 8 | hs_err_pid*.log 9 | test/output/* 10 | target/bin/ 11 | clojure-src.jar 12 | clojure.jar 13 | target/ 14 | bin/ 15 | .settings/ 16 | pom.xml.asc 17 | .nrepl-port 18 | FunnyQT.docset/ 19 | -------------------------------------------------------------------------------- /.project: -------------------------------------------------------------------------------- 1 | 2 | 3 | funnyqt 4 | 5 | 6 | 7 | 8 | 9 | ccw.leiningen.builder 10 | 11 | 12 | 13 | 14 | ccw.builder 15 | 16 | 17 | 18 | 19 | org.eclipse.jdt.core.javabuilder 20 | 21 | 22 | 23 | 24 | 25 | org.eclipse.jdt.core.javanature 26 | ccw.nature 27 | ccw.leiningen.nature 28 | 29 | 30 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: clojure 2 | lein: lein2 3 | sudo: false 4 | branches: 5 | only: 6 | - master 7 | cache: 8 | directories: 9 | - $HOME/.m2 10 | jdk: 11 | # - openjdk8 # still no OpenJDK8 on the Travis machines 12 | - oraclejdk8 13 | -------------------------------------------------------------------------------- /dev/user.clj: -------------------------------------------------------------------------------- 1 | (ns user 2 | (:require [funnyqt.generic :as g] 3 | [funnyqt.utils :as u] 4 | [funnyqt.tg :as tg] 5 | [funnyqt.emf :as emf] 6 | [funnyqt.query :as q] 7 | [funnyqt.pmatch :as pmatch] 8 | [funnyqt.polyfns :as poly] 9 | [funnyqt.in-place :as ip] 10 | [funnyqt.model2model :as m2m] 11 | [funnyqt.bidi :as bidi] 12 | [funnyqt.visualization :as viz] 13 | [funnyqt.edn :as edn] 14 | [vinyasa.inject :as vinj])) 15 | 16 | ;; Inject into namespace . 17 | (vinj/in [funnyqt.visualization print-model]) 18 | -------------------------------------------------------------------------------- /logos/funnyqt.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jgralab/funnyqt/ace568efa4ba7dcfbd9fe61d6c97890c53b58998/logos/funnyqt.pdf -------------------------------------------------------------------------------- /logos/funnyqt.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jgralab/funnyqt/ace568efa4ba7dcfbd9fe61d6c97890c53b58998/logos/funnyqt.png -------------------------------------------------------------------------------- /logos/funnyqt.svg: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 25 | 27 | 30 | 34 | 35 | 38 | 42 | 43 | 46 | 50 | 54 | 55 | 57 | 61 | 65 | 66 | 76 | 78 | 82 | 86 | 87 | 97 | 99 | 103 | 107 | 108 | 118 | 127 | 128 | 155 | 159 | 160 | 162 | 163 | 165 | image/svg+xml 166 | 168 | 169 | 170 | 171 | 172 | 178 | Functional Queries & Transformations 190 | unny 203 | QT 216 | F 228 | 229 | 235 | 236 | -------------------------------------------------------------------------------- /logos/icon16.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jgralab/funnyqt/ace568efa4ba7dcfbd9fe61d6c97890c53b58998/logos/icon16.png -------------------------------------------------------------------------------- /logos/icon32.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jgralab/funnyqt/ace568efa4ba7dcfbd9fe61d6c97890c53b58998/logos/icon32.png -------------------------------------------------------------------------------- /make-and-upload-docs.sh: -------------------------------------------------------------------------------- 1 | #!/bin/zsh 2 | 3 | echo "Deleting the old docs" 4 | rm docs/* 5 | 6 | lein with-profile docs html5-docs 7 | 8 | if [[ $? -eq 0 ]]; then 9 | echo "Deleting the old docs on helena" 10 | ssh horn@134.119.24.195 'rm /home/horn/www/funnyqt-api/*' 11 | echo "Copying over the new docs" 12 | scp -r docs/* horn@134.119.24.195:/home/horn/www/funnyqt-api/ 13 | echo "Adjusting the permissions" 14 | ssh horn@134.119.24.195 \ 15 | 'cd /home/horn/www/funnyqt-api && chmod -R 644 *' 16 | echo Fini. 17 | else 18 | echo Error. 19 | fi 20 | 21 | lein with-profile docs html5-docs :docset 22 | -------------------------------------------------------------------------------- /project.clj: -------------------------------------------------------------------------------- 1 | (defproject funnyqt "1.1.6" 2 | :description "A model querying and transformation library for TGraphs and EMF 3 | models developed as part of Tassilo Horn's dissertation studies." 4 | :dependencies [[org.clojure/clojure "1.10.0"] 5 | [org.clojure/core.cache "0.7.1"] 6 | [org.clojure/data.priority-map "0.0.10"] 7 | [de.uni-koblenz.ist/jgralab "8.1.0"] 8 | [org.clojure/core.logic "0.8.11"] 9 | [org.flatland/ordered "1.5.7"] 10 | [org.clojure/tools.macro "0.1.5"] 11 | [emf-xsd-sdk "2.11.1"] 12 | [inflections "0.13.0" :exclusions [org.clojure/clojure]]] 13 | :profiles {:dev {:source-paths ["dev"] 14 | :dependencies [[im.chit/vinyasa "0.4.7"]] 15 | ;; Don't omit stack traces 16 | :jvm-opts ^:replace ["-Xmx1G" "-XX:-OmitStackTraceInFastThrow"]}} 17 | ;; Don't put version control dirs into the jar 18 | :jar-exclusions [#"(?:^|/).(svn|hg|git)/"] 19 | :resource-paths ["resources"] 20 | :global-vars {*warn-on-reflection* true} 21 | :jvm-opts ^:replace ["-server" "-XX:+AggressiveOpts" "-Xmx1G"] 22 | :license {:name "GNU General Public License, Version 3 (or later)" 23 | :url "http://www.gnu.org/licenses/gpl.html" 24 | :distribution :repo} 25 | :url "http://funnyqt.org" 26 | :repl-options {:init (println "Welcome to FunnyQT!")} 27 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 28 | ;; Stuff specific to generating API docs 29 | :html5-docs-name "FunnyQT" 30 | ;; :html5-docs-page-title nil ;; => "FunnyQT API Documentation" 31 | ;; :html5-docs-source-path "src/" 32 | :html5-docs-docset-icons ["logos/icon16.png" "logos/icon32.png"] 33 | :html5-docs-ns-includes #"^funnyqt\..*" 34 | :html5-docs-ns-excludes #".*\.(internal|tmp-elem|relational\.util)$" 35 | ;; :html5-docs-docs-dir nil ;; => "docs" 36 | :html5-docs-repository-url #(str "https://github.com/jgralab/funnyqt/blob/v" 37 | (:version %))) 38 | -------------------------------------------------------------------------------- /resources/check16.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jgralab/funnyqt/ace568efa4ba7dcfbd9fe61d6c97890c53b58998/resources/check16.png -------------------------------------------------------------------------------- /resources/cross16.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jgralab/funnyqt/ace568efa4ba7dcfbd9fe61d6c97890c53b58998/resources/cross16.png -------------------------------------------------------------------------------- /resources/pattern-schema.tg: -------------------------------------------------------------------------------- 1 | TGraph 2; 2 | Schema de.uni_koblenz.jgralab.patternschema.PatternSchema; 3 | GraphClass PatternGraph { patternName : String }; 4 | 5 | abstract VertexClass AVertex; 6 | 7 | abstract VertexClass APatternVertex : AVertex 8 | { name : String, type : String }; 9 | 10 | VertexClass PatternVertex : APatternVertex; 11 | 12 | VertexClass ArgumentVertex : APatternVertex; 13 | 14 | VertexClass BindingVarVertex : APatternVertex; 15 | 16 | EnumDomain Container (FROM, TO); 17 | 18 | abstract EdgeClass APatternEdge 19 | from APatternVertex (0,*) role src 20 | to APatternVertex (0,*) role dst 21 | { container : Container, type : String }; 22 | 23 | EdgeClass PatternEdge : APatternEdge 24 | from APatternVertex (0,*) 25 | to APatternVertex (0,*) 26 | { name : String }; 27 | 28 | EdgeClass NegPatternEdge : APatternEdge 29 | from APatternVertex (0,*) 30 | to APatternVertex (0,*) ; 31 | 32 | EdgeClass ArgumentEdge : APatternEdge 33 | from APatternVertex (0,*) 34 | to APatternVertex (0,*) 35 | { name : String }; 36 | 37 | VertexClass Anchor : AVertex; 38 | 39 | abstract VertexClass ConstraintOrBinding : AVertex 40 | { form : String }; 41 | 42 | VertexClass Constraint : ConstraintOrBinding; 43 | VertexClass Binding : ConstraintOrBinding; 44 | VertexClass ConstraintAndBinding : Constraint, Binding; 45 | 46 | 47 | EdgeClass Precedes 48 | from AVertex (1,1) 49 | to AVertex (0,1); 50 | -------------------------------------------------------------------------------- /resources/state-space-schema.tg: -------------------------------------------------------------------------------- 1 | TGraph 2; 2 | Schema de.uni_koblenz.jgralab.statespaceschema.StateSpaceSchema; 3 | GraphClass StateSpaceGraph; 4 | 5 | abstract VertexClass State {n : Integer, done : Set = "{}"}; 6 | VertexClass ValidState : State; 7 | VertexClass InvalidState : State {failed : Set = "{}"}; 8 | abstract EdgeClass Transition from State (0,*) role src to State (0,*) role trg {rule : String}; 9 | EdgeClass ValidTransition : Transition from State (0,*) to State (0,*); 10 | EdgeClass InvalidTransition : Transition from State (0,*) to State (0,*) {failed : Set = "{}"}; 11 | -------------------------------------------------------------------------------- /resources/xml-schema.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jgralab/funnyqt/ace568efa4ba7dcfbd9fe61d6c97890c53b58998/resources/xml-schema.pdf -------------------------------------------------------------------------------- /resources/xml-schema.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jgralab/funnyqt/ace568efa4ba7dcfbd9fe61d6c97890c53b58998/resources/xml-schema.png -------------------------------------------------------------------------------- /resources/xml-schema.tg: -------------------------------------------------------------------------------- 1 | TGraph 2; 2 | 3 | Schema de.uni_koblenz.xmltg.XMLSchema; 4 | GraphClass XMLGraph; 5 | 6 | abstract VertexClass Node; 7 | abstract VertexClass NamespacedElement {nsURI: String, nsPrefix: String}; 8 | abstract VertexClass Referent; 9 | VertexClass Element: Node, NamespacedElement {name: String, declaredNamespaces: Map}; 10 | VertexClass RootElement: Element; 11 | VertexClass CharContent: Node, Referent {content: String}; 12 | VertexClass Attribute: NamespacedElement, Referent {name: String, value: String}; 13 | 14 | EdgeClass HasAttribute from Element (1,1) role element to Attribute (0,*) role attributes aggregation composite; 15 | EdgeClass References from Referent (0,*) role referents to Element (0,*) role targets; 16 | 17 | abstract EdgeClass HasContent from Element (0,1) role parent to Node (0,*) role contents aggregation composite; 18 | EdgeClass HasChild: HasContent from Element (0,1) to Element (0,*) role children aggregation composite; 19 | EdgeClass HasCharContent: HasContent from Element (0,1) to CharContent (0,*) role charContents aggregation composite; 20 | -------------------------------------------------------------------------------- /src/funnyqt/bidi/internal.clj: -------------------------------------------------------------------------------- 1 | (ns funnyqt.bidi.internal 2 | "Internals needed by the bidi implementation." 3 | (:require [clojure.core.logic :as ccl] 4 | [clojure.tools.macro :as tm] 5 | [clojure.walk :as cw] 6 | [flatland.ordered.map :as om] 7 | [funnyqt 8 | [generic :as g] 9 | [utils :as u]] 10 | [funnyqt.relational 11 | [tmp-elem :as tmp] 12 | [util :as ru]])) 13 | 14 | (defn select-match 15 | "Only for internal use. 16 | Simply returns the first match. Throws an exception if there's none." 17 | [matches relation src-match] 18 | (when-not (seq matches) 19 | (u/errorf "Couldn't create a %s target match for source match: %s" 20 | relation src-match)) 21 | (first matches)) 22 | 23 | (defn ^:private replace-tmps-and-wrappers-with-manifestations 24 | "Only for internal use." 25 | [trg-match] 26 | (into {} 27 | (map (fn [[k v]] 28 | [k (if (tmp/tmp-or-wrapper-element? v) 29 | (tmp/manifestation v) 30 | v)])) 31 | trg-match)) 32 | 33 | (defn enforce-match 34 | "Only for internal use. 35 | Manifests the temporary and wrapper elements in `match`." 36 | [match id-map-atom] 37 | ;; First manifest the temps and wrappers... 38 | (doseq [el (vals match) 39 | :when (tmp/tmp-or-wrapper-element? el)] 40 | (tmp/manifest el) 41 | (swap! id-map-atom (fn [m] 42 | (if-let [[el v] (find m el)] 43 | (let [m (dissoc m el)] 44 | (assoc m (tmp/manifestation el) v)) 45 | m)))) 46 | ;; ... then remove unneeded tmps and wrappers from the id-map 47 | (let [new-match (replace-tmps-and-wrappers-with-manifestations match) 48 | els (into #{} (vals new-match))] 49 | (swap! id-map-atom (fn [m] 50 | (let [tr (filter (fn [el] 51 | (and (tmp/tmp-or-wrapper-element? el) 52 | (not (els el)))) 53 | (keys m))] 54 | (apply dissoc m tr)))) 55 | new-match)) 56 | 57 | (defn src-initializeo 58 | "Only for internal use." 59 | [args-map & lvars] 60 | (fn [a] 61 | (ccl/unify a (vec lvars) 62 | (mapv (fn [lv] 63 | (let [val (get args-map (keyword (:oname lv)) ::unknown)] 64 | (if (= val ::unknown) lv val))) 65 | lvars)))) 66 | 67 | (defn maybe-wrap 68 | "Wraps `val` in a WrapperElement if it is a model object. Else returns `val` 69 | unchanged. Only for internal use." 70 | [target-model val] 71 | (if (and (or (g/element? val) (g/relationship? val)) 72 | tmp/*make-tmp-elements*) 73 | (tmp/make-wrapper target-model val) 74 | val)) 75 | 76 | (defn trg-initializeo 77 | "Only for internal use." 78 | [target-model enforcing src-match args-map & lvars] 79 | (fn [a] 80 | (ccl/unify a (vec lvars) 81 | (mapv (fn [lv] 82 | (let [lv-kw (keyword (:oname lv)) 83 | src-val (get src-match lv-kw ::unknown) 84 | args-val (get args-map lv-kw ::unknown)] 85 | (cond 86 | (not= src-val ::unknown) 87 | (maybe-wrap target-model src-val) 88 | 89 | (not= args-val ::unknown) 90 | (maybe-wrap target-model args-val) 91 | 92 | :else lv))) 93 | lvars)))) 94 | 95 | (defn check-t-relation-args 96 | "Only for internal use. 97 | Check if the provided args in arg-map are valid (that is, in good-args)." 98 | [relsym arg-map good-args] 99 | (when-let [unbound-key (some #(when-not (good-args %) %) (keys arg-map))] 100 | (u/errorf "Unbound keyword arg %s when calling relation %s." 101 | unbound-key relsym))) 102 | 103 | (defn id [map-atom elem val] 104 | (fn [a] 105 | (let [gelem (ccl/walk* a elem) 106 | gelem (if (tmp/wrapper-element? gelem) 107 | (tmp/manifestation gelem) 108 | gelem) 109 | gval (ccl/walk* a val) 110 | [melem mval] (find @map-atom gelem)] 111 | (when-not (ru/ground? gelem) 112 | (u/error "elem must be ground in (id elem val) goals.")) 113 | (if melem 114 | (ccl/unify a [gelem gval] [melem mval]) 115 | (do 116 | (swap! map-atom assoc gelem gval) 117 | (ccl/succeed a)))))) 118 | 119 | (defn delete-unmatched-target-elements 120 | [left right dir trace] 121 | (when-not (#{:right :left} dir) 122 | (u/error "Must not be used in checkonly transformations.")) 123 | (let [matched-els (into #{} (comp 124 | (mapcat identity) 125 | (mapcat vals) 126 | (filter g/element?)) 127 | (->> trace :related vals))] 128 | (doseq [el (g/elements (if (= dir :right) right left))] 129 | (when (not (matched-els el)) 130 | (g/delete! el false))))) 131 | -------------------------------------------------------------------------------- /src/funnyqt/edn.clj: -------------------------------------------------------------------------------- 1 | (ns funnyqt.edn 2 | "Printing/persisting and reading/loading query results and transformation 3 | traces as EDN." 4 | (:refer-clojure :exclude [pr prn pr-str read read-string slurp spit]) 5 | (:require [clojure.edn :as edn] 6 | [clojure.java.io :as io] 7 | [funnyqt 8 | [emf :as emf] 9 | [query :as q] 10 | [tg :as tg] 11 | [utils :as u]]) 12 | (:import org.eclipse.emf.common.util.URI 13 | org.eclipse.emf.ecore.EObject 14 | [org.eclipse.emf.ecore.resource Resource ResourceSet])) 15 | 16 | ;;# Writing EDN 17 | 18 | ;;## Public API 19 | 20 | (def ^:dynamic *edn-emf-store-resources-by-simple-name* 21 | "If true, store references to EMF resources as simple names only. 22 | If false, store such references as URIs. 23 | 24 | Storing as simple names makes the EDN representation agnostic from the actual 25 | paths where the resources reside, i.e., even after a resource has been moved, 26 | the EDN data is still readable. However, you can't have links to different 27 | resources with have the same simple name but are located in different 28 | directories. 29 | 30 | Storing as URIs considers the complete path (including file name). Thus, you 31 | can store references to resources with the same simple name residing in 32 | different folders. However, moving a resource will make the EDN unreadable. 33 | 34 | In both cases, renaming a resource makes the EDN unreadable. In an ideal 35 | world, resources would have a unique identifier that gets intialized when a 36 | resource is created and then never changes afterwards, but that's just 37 | dreaming." 38 | true) 39 | 40 | (defprotocol IWriteEDN 41 | "Protocol for writing data as EDN. 42 | 43 | By default, all EDN types listed on http://edn-format.org are supported, plus 44 | several JGraLab types (Graph, Vertex, Edge) and EMF types (ResourceSet, 45 | Resource, EObject). 46 | 47 | To support other modeling frameworks, simply extend this protocol to its 48 | types, and also provide corresponding reader functions in `edn-readers`." 49 | (write-edn [obj out] 50 | "Write the EDN representation of `obj` to `out` (a java.util.Writer).")) 51 | 52 | (defn pr 53 | "Prints `obj`s EDN representation to the current value of `*out*`." 54 | [obj] 55 | (write-edn obj *out*)) 56 | 57 | (defn prn 58 | "Prints `obj`s EDN representation + newline to the current value of `*out*`." 59 | [obj] 60 | (write-edn obj *out*) 61 | (.write *out* "\n")) 62 | 63 | (defn ^java.lang.String pr-str 64 | "Returns `obj`s EDN representation as a string." 65 | ^java.lang.String [obj] 66 | (binding [*out* (java.io.StringWriter.)] 67 | (pr obj) 68 | (.toString *out*))) 69 | 70 | (defn spit 71 | "Spits `obj`s EDN representation to `file`. 72 | If the file already exists, it will be overwritten." 73 | [obj file] 74 | (with-open [w (io/writer file)] 75 | (binding [*out* w] 76 | (prn obj)))) 77 | 78 | ;;## Internals and implementation 79 | 80 | (defn ^:private write-edn-sequential-contents [s ^java.io.Writer out] 81 | (let [first (volatile! true)] 82 | (doseq [x s] 83 | (if @first 84 | (vreset! first false) 85 | (.write out ", ")) 86 | (write-edn x out)))) 87 | 88 | (defn ^:private write-edn-vector [v ^java.io.Writer out] 89 | (.write out "[") 90 | (write-edn-sequential-contents v out) 91 | (.write out "]")) 92 | 93 | (defn ^:private write-edn-list [l ^java.io.Writer out] 94 | (.write out "(") 95 | (write-edn-sequential-contents l out) 96 | (.write out ")")) 97 | 98 | (extend-protocol IWriteEDN 99 | ;; Standard Types supported in EDN 100 | nil 101 | (write-edn [n ^java.io.Writer out] 102 | (.write out "nil")) 103 | java.lang.Boolean 104 | (write-edn [b ^java.io.Writer out] 105 | (.write out (Boolean/toString b))) 106 | java.lang.Character 107 | (write-edn [c ^java.io.Writer out] 108 | (print-dup c out)) 109 | clojure.lang.Symbol 110 | (write-edn [sym ^java.io.Writer out] 111 | (.write out (.toString sym))) 112 | clojure.lang.Keyword 113 | (write-edn [kw ^java.io.Writer out] 114 | (.write out (.toString kw))) 115 | java.lang.Number 116 | (write-edn [n ^java.io.Writer out] 117 | (.write out (str n))) 118 | java.lang.String 119 | (write-edn [n ^java.io.Writer out] 120 | (.write out (clojure.core/pr-str n))) 121 | java.util.Map 122 | (write-edn [m ^java.io.Writer out] 123 | (.write out "{") 124 | (let [first (volatile! true)] 125 | (doseq [[k v] m] 126 | (if @first 127 | (vreset! first false) 128 | (.write out ", ")) 129 | (write-edn k out) 130 | (.write out " ") 131 | (write-edn v out))) 132 | (.write out "}")) 133 | java.util.Set 134 | (write-edn [s ^java.io.Writer out] 135 | (.write out "#{") 136 | (write-edn-sequential-contents s out) 137 | (.write out "}")) 138 | java.util.Collection 139 | (write-edn [coll ^java.io.Writer out] 140 | (if (instance? java.util.RandomAccess coll) 141 | (write-edn-vector coll out) 142 | (write-edn-list coll out))) 143 | ;; TGraphs, Vertices, and Edges 144 | de.uni_koblenz.jgralab.Graph 145 | (write-edn [g ^java.io.Writer out] 146 | (.write out "#funnyqt.tg/Graph ") 147 | (write-edn (tg/id g) out)) 148 | de.uni_koblenz.jgralab.Vertex 149 | (write-edn [v ^java.io.Writer out] 150 | (.write out "#funnyqt.tg/Vertex ") 151 | (write-edn [(tg/graph v) (tg/id v)] out)) 152 | de.uni_koblenz.jgralab.Edge 153 | (write-edn [e ^java.io.Writer out] 154 | (.write out "#funnyqt.tg/Edge ") 155 | (write-edn [(tg/graph e) (tg/id e)] out)) 156 | ;; EMF Resources and EObjects 157 | URI 158 | (write-edn [uri ^java.io.Writer out] 159 | (.write out "#funnyqt.emf/URI ") 160 | (write-edn (.toString uri) out)) 161 | Resource 162 | (write-edn [r ^java.io.Writer out] 163 | (.write out "#funnyqt.emf/Resource ") 164 | (let [uri (.getURI r)] 165 | (write-edn (if *edn-emf-store-resources-by-simple-name* 166 | (.lastSegment uri) 167 | uri) 168 | out))) 169 | ResourceSet 170 | (write-edn [rs ^java.io.Writer out] 171 | (.write out "#funnyqt.emf/ResourceSet ") 172 | (write-edn (set (.getResources rs)) out)) 173 | EObject 174 | (write-edn [eo ^java.io.Writer out] 175 | (.write out "#funnyqt.emf/EObject ") 176 | (if-let [r (.eResource eo)] 177 | (write-edn [r (.getURIFragment r eo)] out) 178 | (u/errorf "Cannot write EObject not contained in a Resource: %s" eo)))) 179 | 180 | ;;# Reading EDN 181 | 182 | (def ^:dynamic *models* 183 | "Bound to a set of models during calls to `read-edn`, `read-string`, and 184 | `slurp`." nil) 185 | 186 | ;;## Internals and Implementation 187 | 188 | (defn ^:private edn-tg-graph-reader [id] 189 | (q/the #(and (instance? de.uni_koblenz.jgralab.Graph %) 190 | (= id (tg/id %))) 191 | *models*)) 192 | 193 | (defn ^:private edn-tg-vertex-reader [[g vid]] 194 | (tg/vertex g vid)) 195 | 196 | (defn ^:private edn-tg-edge-reader [[g eid]] 197 | (tg/edge g eid)) 198 | 199 | (defn ^:private edn-emf-resource-reader [uri-or-filename] 200 | (let [matches? (if (instance? URI uri-or-filename) 201 | #(= uri-or-filename %) 202 | #(= uri-or-filename (.lastSegment ^URI %))) 203 | rs (filter (fn [m] 204 | (and (instance? Resource m) 205 | (matches? (.getURI ^Resource m)))) 206 | (concat *models* 207 | (sequence (comp (filter #(instance? ResourceSet %)) 208 | (mapcat (fn [^ResourceSet rs] 209 | (.getResources rs)))) 210 | *models*)))] 211 | (if (seq rs) 212 | (first rs) 213 | (u/errorf "No Resource for URI %s" uri-or-filename)))) 214 | 215 | (defn ^:private edn-emf-resource-set-reader [set-of-resources] 216 | (q/the (fn [m] 217 | (and (instance? ResourceSet m) 218 | (let [rs (set (.getResources ^ResourceSet m))] 219 | (every? #(q/member? % rs) set-of-resources)))) 220 | *models*)) 221 | 222 | (defn ^:private edn-emf-eobject-reader [[^Resource resource fragment]] 223 | (.getEObject resource fragment)) 224 | 225 | (defn ^:private edn-emf-uri-reader [uri] 226 | (URI/createURI uri)) 227 | 228 | ;;## Public API 229 | 230 | (def edn-readers 231 | "A map of FunnyQT EDN tags to vars of functions that should be used for such 232 | an EDN data element. 233 | 234 | To add support for other data types, add readers here and implement the 235 | writing part by extending the `IWriteEDN` protocol upon these types." 236 | {'funnyqt.tg/Graph #'edn-tg-graph-reader 237 | 'funnyqt.tg/Vertex #'edn-tg-vertex-reader 238 | 'funnyqt.tg/Edge #'edn-tg-edge-reader 239 | 'funnyqt.emf/Resource #'edn-emf-resource-reader 240 | 'funnyqt.emf/ResourceSet #'edn-emf-resource-set-reader 241 | 'funnyqt.emf/EObject #'edn-emf-eobject-reader 242 | 'funnyqt.emf/URI #'edn-emf-uri-reader}) 243 | 244 | (defn read 245 | "Read and return one object from `stream` and consider references into/to `models`. 246 | For `opts` see `clojure.edn/read`." 247 | ([stream models] 248 | (read {} stream models)) 249 | ([opts stream models] 250 | (binding [*models* (set models)] 251 | (edn/read (update-in opts [:readers] merge edn-readers) 252 | stream)))) 253 | 254 | (defn read-string 255 | "Read and return one object from `string` and consider references into/to `models`. 256 | For `opts` see `clojure.edn/read-string`." 257 | ([string models] 258 | (read-string {} string models)) 259 | ([opts string models] 260 | (binding [*models* (set models)] 261 | (edn/read-string (update-in opts [:readers] merge edn-readers) 262 | string)))) 263 | 264 | (defn slurp 265 | "Read and return one object from `stream` and consider references into/to `models`. 266 | For `opts` see `clojure.edn/read`." 267 | ([file models] 268 | (slurp {} file models)) 269 | ([opts file models] 270 | (with-open [reader (java.io.PushbackReader. (io/reader file))] 271 | (read opts reader models)))) 272 | -------------------------------------------------------------------------------- /src/funnyqt/internal.clj: -------------------------------------------------------------------------------- 1 | (ns funnyqt.internal 2 | "Protocols for implementation internals only.") 3 | 4 | (defprotocol IAdjacenciesInternal 5 | "A protocol for retrieving adjacent elements." 6 | (adjs-internal [el role allow-unknown-role single-valued] 7 | "Returns the collection of elements adjacent to `el` by reference `role`. 8 | 9 | If `allow-unknown-role` is true, simply returns an empty collection if `role` 10 | is undefined for `el`. Else, throws an exception in that case. 11 | 12 | If `single-valued` is true and `role` is a multi-valued role, throws an 13 | exception.")) 14 | -------------------------------------------------------------------------------- /src/funnyqt/polyfns.clj: -------------------------------------------------------------------------------- 1 | (ns funnyqt.polyfns 2 | "Polymorphic functions dispatching on types of model elements. 3 | 4 | Every polyfn must be declared first, and then arbitrary many implementations 5 | for several metamodel types may be provided. A polyfn must have a model 6 | element as first argument which is used to dispatch among implementations. 7 | 8 | Every polyfn has to be declared once using `declare-polyfn`, and then 9 | implementations for specific types map be provided using `defpolyfn`. When a 10 | polyfn is called, the most specific implementation for the model element type 11 | is invoked. In case of multiple inheritance, a class inheriting two different 12 | implementations is an error. It must provide an own implementation in order 13 | to remove ambiguities. 14 | 15 | Example 16 | ------- 17 | 18 | Let's consider our metamodel has the types TypeA and TypeB, and a TypeC that 19 | extends both TypeA and TypeB. Furthermore, TypeD extends TypeC. Lastly, 20 | there's a TypeE with no inheritance relationships. 21 | 22 | ;; Declare a polyfn 23 | (declare-polyfn foo [elem ...] 24 | ;; Optional default behavior 25 | (str \"Don't know how to handle \" elem)) 26 | 27 | ;; Define implementations for several types 28 | (defpolyfn foo TypeA [elem ...] ...) 29 | (defpolyfn foo TypeB [elem ...] ...) 30 | (defpolyfn foo TypeC [elem ...] ...) 31 | 32 | Then, (foo objOfTypeA) invokes the first implementation, (foo objOfTypeB) 33 | invokes the second implementation, both (foo objOfTypeC) and (foo objOfTypeD) 34 | invoke the third implementation, and (foo objOfTypeE) invokes the default 35 | behavior. If no optional default behavior is specified, an exception is 36 | thrown. 37 | 38 | An impl can also be defined for many types at once. In that case, a list of 39 | types is provided: 40 | 41 | (defpolyfn foo (TypeX TypeY TypeZ) [elem ...] ...)" 42 | (:require [clojure.tools.macro :as tm] 43 | [funnyqt 44 | [utils :as u] 45 | [generic :as g]])) 46 | 47 | ;;# Utility protocols 48 | 49 | (defn find-polyfn-impl 50 | ([polyfn-sym spec-map type] 51 | (find-polyfn-impl polyfn-sym spec-map type type)) 52 | ([polyfn-sym spec-map orig-type type] 53 | (or (spec-map (g/qname type)) 54 | (and (satisfies? g/IUniqueName type) 55 | (spec-map (g/uname type))) 56 | (let [impls (into #{} 57 | (comp (map (partial find-polyfn-impl polyfn-sym spec-map orig-type)) 58 | (remove nil? )) 59 | (g/mm-direct-superclasses type))] 60 | (if (fnext impls) 61 | (u/errorf "Multiple %s polyfn impls for type %s." 62 | polyfn-sym (g/qname orig-type)) 63 | (first impls)))))) 64 | 65 | (defn build-polyfn-dispatch-table [polyfn-var cls] 66 | (let [meta-map (meta polyfn-var) 67 | spec-map (deref (::polyfn-spec-table meta-map)) 68 | dispatch-map-atom (::polyfn-dispatch-table meta-map)] 69 | (let [dm (apply hash-map (mapcat (fn [c] 70 | (when-let [pfn (find-polyfn-impl (:name meta-map) 71 | spec-map c)] 72 | [c pfn])) 73 | (concat (g/mm-element-classes cls) 74 | (when (satisfies? g/IMMRelationshipClasses cls) 75 | (g/mm-relationship-classes cls)))))] 76 | (reset! dispatch-map-atom dm)))) 77 | 78 | ;;# Polyfns 79 | 80 | (defmacro declare-polyfn 81 | "Decares a polymorphic function dispatching on a model element type. 82 | `name` is the name of the new polyfn, an optional `doc-string` may be 83 | provided. The argument list's first element must be the model element on 84 | whose type the dispatch is done. Polymorphic functions for several metamodel 85 | types are provided later using `defpolyfn`. If an optional `body` is 86 | provided, this is executed if no implementation for `model-elem`s type was 87 | added using `defpolyfn`. The default behavior in that case (i.e., `body` 88 | omitted) is to throw an exception. 89 | 90 | By default, when a polyfn is called for the very first time a dispatch table 91 | is computed which maps metamodel classes to the implementation for that type. 92 | If the metamodel changes afterwards, then the dispatch table might be wrong 93 | and needs to be recomputed which will happen if one reset!s 94 | the ::polyfn-dispatch-table metadata atom to nil. One can also omit building 95 | a dispatch table by adding :no-dispatch-table metadata to the polyfn name or 96 | by setting it to true in the polyfn's `attr-map`. In that case, the 97 | implementation is computed with each call and never cached." 98 | 99 | {:arglists '([name doc-string? attr-map? [model-elem & more] & body])} 100 | [name & more] 101 | (let [[name more] (tm/name-with-attributes name more) 102 | [attr-map more] (if (map? (first more)) 103 | [(first more) (rest more)] 104 | [{} more]) 105 | argvec (first more) 106 | body (next more) 107 | type-var (gensym "type__") 108 | attr-map (let [am (merge (meta name) 109 | attr-map 110 | {::polyfn-spec-table `(atom {})})] 111 | (if (:no-dispatch-table am) 112 | am 113 | (assoc am ::polyfn-dispatch-table `(atom nil))))] 114 | `(defn ~name ~attr-map 115 | ~argvec 116 | ~(if (:no-dispatch-table attr-map) 117 | `(if-let [f# (find-polyfn-impl (:name (meta #'~name)) 118 | @(::polyfn-spec-table (meta #'~name)) 119 | (g/mm-class ~(first argvec)))] 120 | (f# ~argvec) 121 | (do 122 | ~@(or body 123 | `[(u/errorf "No %s polyfn implementation defined for type %s" 124 | '~name (g/qname ~(first argvec)))]))) 125 | `(let [~type-var (g/mm-class ~(first argvec)) 126 | call-impl# (fn ~'call-polyfn-impl [dispatch-map# ~type-var] 127 | (if-let [f# (dispatch-map# ~type-var)] 128 | (f# ~@argvec) 129 | (do 130 | ~@(or body 131 | `[(u/errorf 132 | "No %s polyfn implementation defined for type %s" 133 | '~name (g/qname ~type-var))]))))] 134 | (if-let [dispatch-map# @(::polyfn-dispatch-table (meta #'~name))] 135 | (call-impl# dispatch-map# ~type-var) 136 | (do 137 | (build-polyfn-dispatch-table #'~name ~type-var) 138 | (call-impl# @(::polyfn-dispatch-table (meta #'~name)) ~type-var)))))))) 139 | 140 | (defmacro defpolyfn 141 | "Defines an implementation of the polyfn `name` for objects of type `type` 142 | or objects of `type1`, `type2`, etc. 143 | The polyfn has to be already declared using `declare-polyfn`. `type` is a 144 | fully qualified type name that is used to check if the polyfn implementation 145 | is matching the type of `model-elem`. The arity of the argument vector has 146 | to match the one of the corresponding `declare-polyfn`." 147 | 148 | {:arglists '([name type [model-elem & more] & body] 149 | [name (type1 type2 ...) [model-elem & more] & body])} 150 | [name & more] 151 | (let [[name more] (tm/name-with-attributes name more) 152 | [types more] [(first more) (next more)] 153 | types (if (seq? types) 154 | (if (= 'quote (first types)) 155 | (u/errorf "The defpolyfn impl type mustn't be quoted: %s" types) 156 | types) 157 | [types]) 158 | [argvec body] [(first more) (next more)]] 159 | (when-not (find (meta (resolve name)) ::polyfn-spec-table) 160 | (u/errorf "#'%s is not declared as a polyfn." name)) 161 | `(do 162 | ~@(for [type types] 163 | (let [^String n (clojure.core/name type)] 164 | (when-not (symbol? type) 165 | (u/errorf "The type given to a defpolyfn must be a symbol but was %s (%s)." 166 | type (class type))) 167 | (when (or (.startsWith n "!") 168 | (.endsWith n "!")) 169 | (u/errorf "The type given to defpolyfn must be a plain qname symbol but was %s." 170 | type)) 171 | ;; Update the specs 172 | `(swap! (::polyfn-spec-table (meta #'~name)) 173 | assoc '~type (fn ~(symbol (str name "--" n)) ~argvec ~@body)))) 174 | ;; Reset the dispatch table if it's a polyfn without :no-dispatch-table 175 | ;; metadata 176 | (when-not (:no-dispatch-table (meta #'~name)) 177 | (reset! (::polyfn-dispatch-table (meta #'~name)) nil))))) 178 | -------------------------------------------------------------------------------- /src/funnyqt/query/emf.clj: -------------------------------------------------------------------------------- 1 | (ns funnyqt.query.emf 2 | "EMF-specific query functions" 3 | (:require [flatland.ordered.set :as os] 4 | [funnyqt 5 | [emf :as emf] 6 | [utils :as u]])) 7 | 8 | ;;# Regular Path Expressions 9 | 10 | (defn <>-- 11 | "Returns the (direct) contents of EObject `obj` restricted by the reference 12 | specification `rs` (see `funnyqt.emf/eref-matcher` for details). `obj` may 13 | also be a collection of EObjects." 14 | ([obj] 15 | (into (os/ordered-set) (mapcat #(emf/econtentrefs % nil)) (u/oset obj))) 16 | ([obj rs] 17 | (into (os/ordered-set) (mapcat #(emf/econtentrefs % rs)) (u/oset obj)))) 18 | 19 | (defn ---> 20 | "Returns the EObjects cross-referenced by `obj` where the references may be 21 | restricted by `rs`, a reference specification (see `funnyqt.emf/eref-matcher` 22 | for details). `obj` may also be a collection of EObjects. In EMF, 23 | cross-referenced means referenced by a non-containment EReference." 24 | ([obj] 25 | (into (os/ordered-set) (mapcat #(emf/ecrossrefs % nil)) (u/oset obj))) 26 | ([obj rs] 27 | (into (os/ordered-set) (mapcat #(emf/ecrossrefs % rs)) (u/oset obj)))) 28 | 29 | (defn --> 30 | "Returns the EObjects referenced by `obj` where the references may be 31 | restricted by `rs`, a reference specification (see `funnyqt.emf/eref-matcher` 32 | for details). `obj` may also be a collection of EObjects. In contrast to 33 | `--->`, this function includes both cross-references and containments." 34 | ([obj] 35 | (into (os/ordered-set) (mapcat #(emf/erefs % nil)) (u/oset obj))) 36 | ([obj rs] 37 | (into (os/ordered-set) (mapcat #(emf/erefs % rs)) (u/oset obj)))) 38 | 39 | (defn --<> 40 | "Returns a seq containing `obj`s container. If there's none, 41 | returns the empty set." 42 | ([obj] 43 | (into (os/ordered-set) 44 | (mapcat #(when-let [c (emf/econtainer %)] 45 | [c])) 46 | (u/oset obj))) 47 | ([obj rs] 48 | (into (os/ordered-set) 49 | (mapcat #(when-let [c (emf/econtainer % rs)] 50 | [c])) 51 | (u/oset obj)))) 52 | 53 | (defn <--- 54 | "Returns all EObjects cross-referencing `obj` with a reference matching the 55 | reference specification `rs` (see `funnyqt.emf/eref-matcher` for details). 56 | `obj` may also be a collection of EObjects, in which case all objects 57 | cross-referencing any of the objects in `obj` is returned. In EMF, 58 | cross-referenced means referenced by a non-containment EReference. 59 | 60 | If no `container` is given, then only the opposite refs of `obj` are checked. 61 | Else, all objects in `container` are tested if they reference `obj` with a 62 | reference matching `rs`. `container` may be either an EObject, a Resource, a 63 | ResourceSet, or a collection of EObjects. For the former three, direct and 64 | indirect contents are checked, for collections only direct contents." 65 | ([obj] 66 | (into (os/ordered-set) (mapcat #(emf/inv-ecrossrefs % nil nil)) (u/oset obj))) 67 | ([obj rs] 68 | (into (os/ordered-set) (mapcat #(emf/inv-ecrossrefs % rs nil)) (u/oset obj))) 69 | ([obj rs container] 70 | (into (os/ordered-set) (mapcat #(emf/inv-ecrossrefs % rs container)) (u/oset obj)))) 71 | 72 | (defn <-- 73 | "Returns all EObjects referencing `obj` with a reference matching the 74 | reference specification `rs` (see `funnyqt.emf/eref-matcher` for details). 75 | `obj` may also be a collection of EObjects, in which case all objects 76 | referencing any of the objects in `obj` is returned. In contrast to `<---', 77 | this function includes both cross-references and containments. 78 | 79 | If no `container` is given, then only the opposite refs of `obj` are checked. 80 | Else, all objects in `container` are tested if they reference `obj` with a 81 | reference matching `rs`. `container` may be either an EObject, a Resource, a 82 | ResourceSet, or a collection of EObjects. For the former three, direct and 83 | indirect contents are checked, for collections only direct contents." 84 | ([obj] 85 | (into (os/ordered-set) (mapcat #(emf/inv-erefs % nil nil)) (u/oset obj))) 86 | ([obj rs] 87 | (into (os/ordered-set) (mapcat #(emf/inv-erefs % rs nil)) (u/oset obj))) 88 | ([obj rs container] 89 | (into (os/ordered-set) (mapcat #(emf/inv-erefs % rs container)) (u/oset obj)))) 90 | -------------------------------------------------------------------------------- /src/funnyqt/query/tg.clj: -------------------------------------------------------------------------------- 1 | (ns funnyqt.query.tg 2 | "TG-specific query functions" 3 | (:require [funnyqt 4 | [query :as q] 5 | [tg :as tg]]) 6 | (:import de.uni_koblenz.jgralab.schema.AggregationKind)) 7 | 8 | ;;# Regular Path Expressions 9 | 10 | ;; refer the private var 11 | (def ^:private --- @#'tg/---) 12 | 13 | (defn --> 14 | "Returns the vertices reachable from `v` via outgoing incidences, 15 | optionally restricted by `ts` and `pred` (on the edges)." 16 | ([v] 17 | (--- v :out nil nil nil nil)) 18 | ([v ts] 19 | (--- v :out nil nil ts nil)) 20 | ([v ts pred] 21 | (--- v :out nil nil ts pred))) 22 | 23 | (defn <-- 24 | "Returns the vertices reachable from `v` via incoming incidences, 25 | optionally restricted by `ts` and `pred` (on the edges)." 26 | ([v] 27 | (--- v :in nil nil nil nil)) 28 | ([v ts] 29 | (--- v :in nil nil ts nil)) 30 | ([v ts pred] 31 | (--- v :in nil nil ts pred))) 32 | 33 | (defn <-> 34 | "Returns the vertices reachable from `v` via all incidences, 35 | optionally restricted by `ts` and `pred` (on the edges)." 36 | ([v] 37 | (--- v :inout nil nil nil nil)) 38 | ([v ts] 39 | (--- v :inout nil nil ts nil)) 40 | ([v ts pred] 41 | (--- v :inout nil nil ts pred))) 42 | 43 | (defn ---> 44 | "Returns the vertices reachable from `v` via outgoing incidences, 45 | optionally restricted by `ts` and `pred` (on the edges). In contrast to 46 | `-->`, traversal of edges with composition semantics is forbidden." 47 | ([v] 48 | (--- v :out 49 | [AggregationKind/NONE AggregationKind/SHARED] 50 | [AggregationKind/NONE AggregationKind/SHARED] nil nil)) 51 | ([v ts] 52 | (--- v :out 53 | [AggregationKind/NONE AggregationKind/SHARED] 54 | [AggregationKind/NONE AggregationKind/SHARED] ts nil)) 55 | ([v ts pred] 56 | (--- v :out 57 | [AggregationKind/NONE AggregationKind/SHARED] 58 | [AggregationKind/NONE AggregationKind/SHARED] ts pred))) 59 | 60 | (defn <--- 61 | "Returns the vertices reachable from `v` via incoming incidences, 62 | optionally restricted by `ts` and `pred` (on the edges). In contrast to 63 | `<--', traversal of edges with composition semantics is forbidden." 64 | ([v] 65 | (--- v :in 66 | [AggregationKind/NONE AggregationKind/SHARED] 67 | [AggregationKind/NONE AggregationKind/SHARED] nil nil)) 68 | ([v ts] 69 | (--- v :in 70 | [AggregationKind/NONE AggregationKind/SHARED] 71 | [AggregationKind/NONE AggregationKind/SHARED] ts nil)) 72 | ([v ts pred] 73 | (--- v :in 74 | [AggregationKind/NONE AggregationKind/SHARED] 75 | [AggregationKind/NONE AggregationKind/SHARED] ts pred))) 76 | 77 | (defn <--> 78 | "Returns the vertices reachable from `v` via all incidences, 79 | optionally restricted by `ts` and `pred` (on the edges). In contrast to 80 | `<->', traversal of edges with composition semantics is forbidden." 81 | ([v] 82 | (--- v :inout 83 | [AggregationKind/NONE AggregationKind/SHARED] 84 | [AggregationKind/NONE AggregationKind/SHARED] nil nil)) 85 | ([v ts] 86 | (--- v :inout 87 | [AggregationKind/NONE AggregationKind/SHARED] 88 | [AggregationKind/NONE AggregationKind/SHARED] ts nil)) 89 | ([v ts pred] 90 | (--- v :inout 91 | [AggregationKind/NONE AggregationKind/SHARED] 92 | [AggregationKind/NONE AggregationKind/SHARED] ts pred))) 93 | 94 | (defn -- 95 | "Aggregation path expression starting at whole `v`, optionally restricted by 96 | `ts` and `pred` (on the edges)." 97 | ([v] 98 | (--- v :inout nil [AggregationKind/SHARED AggregationKind/COMPOSITE] nil nil)) 99 | ([v ts] 100 | (--- v :inout nil [AggregationKind/SHARED AggregationKind/COMPOSITE] ts nil)) 101 | ([v ts pred] 102 | (--- v :inout nil [AggregationKind/SHARED AggregationKind/COMPOSITE] ts pred))) 103 | 104 | (defn -- 105 | "Aggregation path expression starting at part `v`, optionally restricted by 106 | `ts` and `pred` (on the edges)." 107 | ([v] 108 | (--- v :inout [AggregationKind/SHARED AggregationKind/COMPOSITE] nil nil nil)) 109 | ([v ts] 110 | (--- v :inout [AggregationKind/SHARED AggregationKind/COMPOSITE] nil ts nil)) 111 | ([v ts pred] 112 | (--- v :inout [AggregationKind/SHARED AggregationKind/COMPOSITE] nil ts pred))) 113 | 114 | (defn <->-- 115 | "Aggregation-only path expression starting at whole `v`, optionally 116 | restricted by `ts` and `pred` (on the edges)." 117 | ([v] 118 | (--- v :inout nil [AggregationKind/SHARED] nil nil)) 119 | ([v ts] 120 | (--- v :inout nil [AggregationKind/SHARED] ts nil)) 121 | ([v ts pred] 122 | (--- v :inout nil [AggregationKind/SHARED] ts pred))) 123 | 124 | (defn --<-> 125 | "Aggregation-only path expression starting at part `v`, optionally restricted 126 | by `ts` and `pred` (on the edges)." 127 | ([v] 128 | (--- v :inout [AggregationKind/SHARED] nil nil nil)) 129 | ([v ts] 130 | (--- v :inout [AggregationKind/SHARED] nil ts nil)) 131 | ([v ts pred] 132 | (--- v :inout [AggregationKind/SHARED] nil ts pred))) 133 | 134 | (defn <>-- 135 | "Composition path expression starting at whole `v`, optionally restricted by 136 | `ts` and `pred` (on the edges)." 137 | ([v] 138 | (--- v :inout nil [AggregationKind/COMPOSITE] nil nil)) 139 | ([v ts] 140 | (--- v :inout nil [AggregationKind/COMPOSITE] ts nil)) 141 | ([v ts pred] 142 | (--- v :inout nil [AggregationKind/COMPOSITE] ts pred))) 143 | 144 | (defn --<> 145 | "Composition path expression starting at part `v`, optionally restricted by 146 | `ts` and `pred` (on the edges)." 147 | ([v] 148 | (--- v :inout [AggregationKind/COMPOSITE] nil nil nil)) 149 | ([v ts] 150 | (--- v :inout [AggregationKind/COMPOSITE] nil ts nil)) 151 | ([v ts pred] 152 | (--- v :inout [AggregationKind/COMPOSITE] nil ts pred))) 153 | -------------------------------------------------------------------------------- /src/funnyqt/relational/util.clj: -------------------------------------------------------------------------------- 1 | (ns funnyqt.relational.util 2 | "(Internal) Relation writing utilities." 3 | (:require [clojure.core.logic :as ccl])) 4 | 5 | (defn qmark-symbol? [sym] 6 | (and 7 | (symbol? sym) 8 | (= (first (name sym)) \?))) 9 | 10 | (defn fresh? 11 | "Returns true, if `x` is fresh. 12 | `x` must have been `walk`ed before!" 13 | [x] 14 | (ccl/lvar? x)) 15 | 16 | (defn ground? 17 | "Returns true, if `x` is ground. 18 | `x` must have been `walk`ed before!" 19 | [x] 20 | (not (ccl/lvar? x))) 21 | 22 | (defn printo 23 | "Prints `txt` and the (walked) values of `lvars`." 24 | [txt & lvars] 25 | (fn [a] 26 | (println txt (map (partial ccl/walk* a) lvars)) 27 | a)) 28 | -------------------------------------------------------------------------------- /test/funnyqt/edn_test.clj: -------------------------------------------------------------------------------- 1 | (ns funnyqt.edn-test 2 | (:require [clojure.test :refer :all] 3 | [funnyqt 4 | [edn :as edn] 5 | [emf :as emf] 6 | [tg :as tg]])) 7 | 8 | (def test-graph (tg/load-graph "test/input/familygraph.tg")) 9 | 10 | (when (try (do (emf/eclassifier 'FamilyModel) 11 | false) 12 | (catch Exception _ 13 | true)) 14 | (emf/load-ecore-resource "test/input/Families.ecore")) 15 | 16 | (def test-resource-set (doto (emf/new-resource-set) 17 | (emf/new-resource "test/input/Families.ecore") 18 | (emf/new-resource "test/input/example.families"))) 19 | 20 | (def test-resource (emf/get-resource test-resource-set 21 | "test/input/example.families" true)) 22 | 23 | (defn edn-roundtrip [obj & models] 24 | (let [val (edn/read-string (edn/pr-str obj) models) 25 | f (java.io.File/createTempFile "test" "edn")] 26 | (edn/spit obj f) 27 | (is (= obj (edn/slurp f models))) 28 | val)) 29 | 30 | (deftest test-standard-edn-types 31 | ;; nil 32 | (is (nil? (edn-roundtrip nil))) 33 | ;; booleans 34 | (is (true? (edn-roundtrip true))) 35 | (is (false? (edn-roundtrip false))) 36 | ;; characters (& vectors) 37 | (let [chars [\a \@ \€ \newline \space \tab \uFFFF] 38 | result (edn-roundtrip chars)] 39 | (is (= chars result)) 40 | (is (vector? result))) 41 | ;; symbols (& vectors) 42 | (let [syms '[foo bar$ some/sym <&=?%>] 43 | result (edn-roundtrip syms)] 44 | (is (= syms result)) 45 | (is (vector? result))) 46 | ;; keywords (& vectors) 47 | (let [kws [:foo :bar% :some/kw :<&=?%>] 48 | result (edn-roundtrip kws)] 49 | (is (= kws result)) 50 | (is (vector? result))) 51 | ;; numbers (& lists) 52 | (let [nums (list 0 -18 2.817 Math/PI -2.291e19) 53 | result (edn-roundtrip nums)] 54 | (is (= nums result)) 55 | (is (list? result))) 56 | ;; strings (& maps) 57 | (let [strings {"foo" "\n", "String \"with\" quotes" "\nyes\n"} 58 | result (edn-roundtrip strings)] 59 | (is (= strings result)) 60 | (is (map? result))) 61 | ;; sets 62 | (let [sets #{#{3 2 1 0} #{1 -19 -0.5 :foo [0 0 0]} 63 | ;; TODO: Comment in as soon as 64 | ;; http://dev.clojure.org/jira/browse/CLJ-1739 is fixed. 65 | #_(java.util.HashSet. [1 2 3]) 66 | #_(u/oset [2 2 2])} 67 | result (edn-roundtrip sets)] 68 | (is (= sets result)) 69 | (is (set? result)) 70 | (is (every? set? result))) 71 | ;; vectors (& collections implementing RandomAccess) 72 | (let [vs [[1 2 3] (java.util.ArrayList. [3 2 1]) (java.util.Vector. [0 1 1 "foo"])] 73 | result (edn-roundtrip vs)] 74 | (is (= vs result)) 75 | (is (vector? result)) 76 | (is (every? vector? result))) 77 | ;; lists 78 | (let [ls (list (list 1 2 3) (java.util.LinkedList. [3 2 1]) (range 10)) 79 | result (edn-roundtrip ls)] 80 | (is (= ls result)) 81 | (is (list? result)) 82 | (is (every? list? result)))) 83 | 84 | (deftest test-edn-tg 85 | (let [g test-graph 86 | vs (tg/vseq g) 87 | es (tg/eseq g) 88 | rg (edn-roundtrip g test-graph) 89 | rvs (edn-roundtrip vs test-graph) 90 | res (edn-roundtrip es test-graph)] 91 | (is (= g rg)) 92 | (is (= vs rvs)) 93 | (is (= es res)))) 94 | 95 | (defn emf-edn-test [] 96 | (let [r test-resource 97 | rr1 (edn-roundtrip r test-resource) 98 | ;; We can also retrieve a resourse out of a resource set 99 | rr2 (edn-roundtrip r test-resource-set) 100 | 101 | rs test-resource-set 102 | rrs (edn-roundtrip rs test-resource-set) 103 | 104 | eos-r (emf/eallcontents r) 105 | eos-rs (emf/eallcontents rs) 106 | reos-r (edn-roundtrip eos-r test-resource) 107 | reos-rs (edn-roundtrip eos-rs test-resource-set)] 108 | (is (= r rr1 rr2)) 109 | (is (= rs rrs)) 110 | (is (= eos-r reos-r)) 111 | (is (= eos-rs reos-rs)))) 112 | 113 | (deftest test-edn-emf-simple-name 114 | (binding [edn/*edn-emf-store-resources-by-simple-name* true] 115 | (emf-edn-test))) 116 | 117 | (deftest test-edn-emf-uri 118 | (binding [edn/*edn-emf-store-resources-by-simple-name* false] 119 | (emf-edn-test))) 120 | -------------------------------------------------------------------------------- /test/funnyqt/extensional_test.clj: -------------------------------------------------------------------------------- 1 | (ns funnyqt.extensional-test 2 | (:refer-clojure :exclude [parents]) 3 | (:require [clojure.test :refer :all] 4 | [funnyqt 5 | [tg-test :refer [rg]] 6 | [emf :as emf] 7 | [extensional :refer :all] 8 | [generic :refer [adj aval elements enum-constant]] 9 | [query :as q] 10 | [tg :as tg]] 11 | [funnyqt.visualization :as viz])) 12 | 13 | ;;* Helpers 14 | 15 | (defn family 16 | "Returns the main family of member m." 17 | [m] 18 | (or (adj m :familyFather) (adj m :familyMother) 19 | (adj m :familySon) (adj m :familyDaughter))) 20 | 21 | (defn male? 22 | "Returns true, iff member m is male." 23 | [m] 24 | (or (adj m :familyFather) 25 | (adj m :familySon))) 26 | 27 | (defn parents 28 | "Returns the set of parent members of m." 29 | [m] 30 | (q/p-seq m 31 | [q/p-alt :familySon :familyDaughter] 32 | [q/p-alt :father :mother])) 33 | 34 | (defn wife 35 | "Returns the wife member of member m." 36 | [m] 37 | (adj m :familyFather :mother)) 38 | 39 | ;;* Transformation with relationships 40 | 41 | (defn families2genealogy 42 | "Transforms the family model `fs` to the genealogy `g`." 43 | [fs g] 44 | (with-trace-mappings 45 | (create-elements! g 'Male 46 | (fn [] 47 | (filter male? (elements fs 'Member)))) 48 | (create-elements! g 'Female 49 | (fn [] 50 | (remove male? (elements fs 'Member)))) 51 | (set-avals! g 'Person :fullName 52 | (fn [] 53 | (for [[m p] (image-map g 'Person)] 54 | [p (str (aval m :firstName) " " 55 | (aval (family m) :lastName))]))) 56 | (set-avals! g 'Person "ageGroup" 57 | (fn [] 58 | (fn [p] 59 | (let [m (element-archetype p)] 60 | (enum-constant p (if (< (aval m :age) 18) 61 | 'AgeGroup.CHILD 62 | 'AgeGroup.ADULT)))))) 63 | (create-relationships! g 'HasChild 64 | (fn [] 65 | (for [m (elements fs 'Member) 66 | p (parents m)] 67 | [[m p] (source-image m) (target-image p)]))) 68 | (set-adjs! g 'Male :wife 69 | (fn [] 70 | (fn [male] 71 | (let [m (element-archetype male)] 72 | (target-image (wife m)))))) 73 | (create-elements! g 'Address 74 | (fn [] 75 | (for [f (elements fs 'Family)] 76 | [(aval f :street) (aval f :town)]))) 77 | (let [address-arch-map (archetype-map g 'Address)] 78 | (set-avals! g 'Address :street 79 | (fn [] 80 | (fn [addr] 81 | (first (address-arch-map addr))))) 82 | (set-avals! g 'Address :town 83 | (fn [] 84 | (fn [addr] 85 | (second (address-arch-map addr)))))) 86 | (create-relationships! g 'LivesAt 87 | (fn [] 88 | (for [m (elements fs 'Member)] 89 | [m (source-image m) 90 | (let [f (family m)] 91 | (target-image [(aval f :street) (aval f :town)]))]))))) 92 | 93 | ;;* Transformation without relationships 94 | 95 | (defn families2genealogy-no-relationships [m g] 96 | (with-trace-mappings 97 | (create-elements! g 'Male 98 | (fn [] 99 | (filter male? (elements m 'Member)))) 100 | (create-elements! g 'Female 101 | (fn [] 102 | (filter (complement male?) 103 | (elements m 'Member)))) 104 | (set-avals! g 'Person :fullName 105 | (fn [] 106 | (for [mem (elements m 'Member)] 107 | [(element-image mem) 108 | (str (aval mem :firstName) " " 109 | (aval (family mem) :lastName))]))) 110 | (set-adjs! g 'Male :wife 111 | (fn [] 112 | (for [mem (filter wife (elements m 'Member))] 113 | [(element-image mem) (target-image (wife mem))]))) 114 | (add-adjs! g 'Person :parents 115 | (fn [] 116 | (for [child (elements m 'Member) 117 | :let [parents (parents child)] 118 | :when (seq parents)] 119 | [(element-image child) (target-images parents)]))) 120 | (create-elements! g 'Address 121 | (fn [] 122 | (for [f (elements m 'Family)] 123 | [(aval f :street) (aval f :town)]))) 124 | (let [address-arch-map (archetype-map g 'Address)] 125 | (set-avals! g 'Address :street 126 | (fn [] 127 | (fn [addr] 128 | (first (address-arch-map addr))))) 129 | (set-avals! g 'Address :town 130 | (fn [] 131 | (fn [addr] 132 | (second (address-arch-map addr)))))) 133 | (set-adjs! g 'Person :address 134 | (fn [] 135 | (fn [p] 136 | (let [f (family (element-archetype p))] 137 | (target-image [(aval f :street) (aval f :town)]))))))) 138 | 139 | ;;* The tests 140 | 141 | (deftest test-families2genealogy-extensional-tg 142 | (let [g (tg/new-graph (tg/load-schema "test/input/genealogy-schema.tg")) 143 | m (emf/load-resource "test/input/example.families")] 144 | (print "families2genealogy (EMF -> TG): ") 145 | (time (families2genealogy m g)) 146 | ;;(./print-model g :gtk) 147 | (is (= 3 (tg/vcount g 'Address))) 148 | (is (= 13 (tg/vcount g 'Person))) 149 | (is (= 7 (tg/vcount g 'Female))) 150 | (is (= 6 (tg/vcount g 'Male))) 151 | (is (= 13 (tg/ecount g 'LivesAt))) 152 | (is (= 18 (tg/ecount g 'HasChild))) 153 | (is (= 3 (tg/ecount g 'HasSpouse))) 154 | (is (= 21 (tg/ecount g 'HasRelative))))) 155 | 156 | (emf/load-ecore-resource "test/input/Genealogy.ecore") 157 | (emf/load-ecore-resource "test/input/Families.ecore") 158 | 159 | (deftest test-families2genealogy-extensional-emf 160 | (let [g (emf/new-resource) 161 | m (emf/load-resource "test/input/example.families")] 162 | (print "families2genealogy-no-relationships (EMF -> EMF): ") 163 | (time (families2genealogy-no-relationships m g)) 164 | (is (= 13 (count (emf/eallcontents g 'Person)))) 165 | (is (= 7 (count (emf/eallcontents g 'Female)))) 166 | (is (= 6 (count (emf/eallcontents g 'Male)))) 167 | (is (= 3 (count (emf/eallcontents g 'Address)))) 168 | (is (= 13 (count (emf/epairs g :person :address)))) 169 | (is (= 18 (count (emf/epairs g :parents :children)))) 170 | (is (= 3 (count (emf/epairs g :husband :wife)))) 171 | #_(viz/print-model g :gtk))) 172 | 173 | (deftest test-transformation-1 174 | (let [g (tg/new-graph (tg/schema rg))] 175 | (with-trace-mappings 176 | (create-elements! g 'localities.City (fn [] [1 2])) 177 | (set-avals! g 'NamedElement :name 178 | (fn [] 179 | {(element-image 1) "Köln" 180 | (element-image 2) "Frankfurt"})) 181 | (create-elements! g 'junctions.Crossroad (fn [] ["a" "b"])) 182 | (create-relationships! g 'localities.ContainsCrossroad 183 | (fn [] 184 | [[1 (source-image 1) (target-image "a")] 185 | [2 (source-image 2) (target-image "b")]])) 186 | (create-relationships! g 'connections.Street 187 | (fn [] 188 | [[1 (source-image "a") (target-image "b")]]))) 189 | (is (= 4 (tg/vcount g))) 190 | (is (= 3 (tg/ecount g))) 191 | (is (= "Köln" (aval (tg/vertex g 1) :name))) 192 | (is (= "Frankfurt" (aval (tg/vertex g 2) :name))))) 193 | 194 | (deftest test-transformation-2 195 | (is (thrown-with-msg? 196 | Exception #"Bijectivity violation:" 197 | (let [g (tg/new-graph (tg/schema rg))] 198 | (with-trace-mappings 199 | (create-elements! g 'localities.City (fn [] [1])) 200 | ;; This should throw because the archetype 1 is already used. 201 | (create-elements! g 'localities.City (fn [] [1]))))))) 202 | 203 | (deftest test-transformation-3 204 | (is (thrown-with-msg? 205 | Exception #"Bijectivity violation:" 206 | (let [g (tg/new-graph (tg/schema rg))] 207 | (with-trace-mappings 208 | (create-elements! g 'City (fn [] [1 2 3])) 209 | ;; City and County are both NamedElements, so their archetypes must be 210 | ;; disjoint. Thus, the following must fail! 211 | (create-elements! g 'County (fn [] [1 2 3]))))))) 212 | 213 | -------------------------------------------------------------------------------- /test/funnyqt/in_place/emf_test.clj: -------------------------------------------------------------------------------- 1 | (ns ^{:pattern-expansion-context :emf} 2 | funnyqt.in-place.emf-test 3 | (:require [clojure.test :refer :all] 4 | [funnyqt 5 | [emf :as emf] 6 | [generic :as g] 7 | [in-place :refer :all] 8 | [pmatch :as pmatch] 9 | [query :as q] 10 | [tg :as tg]])) 11 | 12 | (emf/load-ecore-resource "test/input/clock.ecore") 13 | 14 | (defn hour [g h] 15 | (q/the #(= h (emf/eget % :hour)) 16 | (emf/eallcontents g 'Hour))) 17 | 18 | (defn ^:private clock-model [] 19 | (let [g (emf/new-resource)] 20 | (dotimes [i 12] 21 | (let [h (emf/ecreate! g 'Hour {:hour (inc i)})] 22 | (when-not (zero? i) 23 | (emf/eset! h :prev (hour g i))))) 24 | (emf/eset! (hour g 12) :next (hour g 1)) 25 | (let [c (emf/ecreate! g 'Clock)] 26 | (emf/eset! c :current (hour g 12))) 27 | g)) 28 | 29 | (defrule tick-forward [g] 30 | [c -<:current>-> <> -<:next>-> nh] 31 | (emf/eset! c :current nh)) 32 | 33 | (defrule tick-backward [g] 34 | [c -<:current>-> <> -<:prev>-> ph] 35 | (emf/eset! c :current ph)) 36 | 37 | (defrule reset-clock [g] 38 | [c -<:current>-> h 39 | :when (not= 12 (emf/eget h :hour))] 40 | (emf/eset! c :current (hour g 12))) 41 | 42 | (deftest test-state-space-1 43 | (let [g (clock-model) 44 | [ssg s2g] (create-state-space 45 | g 46 | g/equal-models? 47 | [tick-forward tick-backward reset-clock])] 48 | ;;(./print-model ssg :gtk) 49 | (is (= 12 (tg/vcount ssg))) 50 | ;; From every Hour we can tick forward and backward, and from every state 51 | ;; except for the first, we can reset to 12 o'clock. 52 | (is (= 35 (tg/ecount ssg))))) 53 | 54 | (deftest test-state-space-2 55 | (let [g (clock-model) 56 | [ssg s2g] (create-state-space 57 | g 58 | #(g/equal-models? %1 %2 true) 59 | [tick-forward tick-backward reset-clock])] 60 | ;;(./print-model ssg :gtk) 61 | (is (= 12 (tg/vcount ssg))) 62 | ;; From every Hour we can tick forward and backward, and from every state 63 | ;; except for the first, we can reset to 12 o'clock. 64 | (is (= 35 (tg/ecount ssg))))) 65 | 66 | (defrule erase-clock-hand [g] 67 | [c -<:current>-> <>] 68 | (emf/eset! c :current nil)) 69 | 70 | (pmatch/defpattern current-hour-exists? [g] 71 | [c -<:current>-> <>]) 72 | 73 | (defn test-explore-state-space [] 74 | (let [g (clock-model)] 75 | (explore-state-space 76 | g 77 | #(g/equal-models? %1 %2 false) 78 | [tick-forward tick-backward reset-clock erase-clock-hand] 79 | {:state-preds [#(seq (current-hour-exists? %))] 80 | :transition-preds {} 81 | :state-space-preds [#(<= (tg/vcount %) 12)]}))) 82 | -------------------------------------------------------------------------------- /test/funnyqt/in_place/tg_test.clj: -------------------------------------------------------------------------------- 1 | (ns ^{:pattern-expansion-context :tg} 2 | funnyqt.in-place.tg-test 3 | (:require [clojure.test :refer :all] 4 | [funnyqt 5 | [generic :as g] 6 | [in-place :refer :all] 7 | [query :as q] 8 | [tg :as tg :refer :all] 9 | [tg-test :refer :all]])) 10 | 11 | ;;* BinTree eval 12 | 13 | (defrule replace-binaryop 14 | "Replaces a binary operation with constant args with 15 | a constant of the result." 16 | [g] [b --> a1 17 | b --> a2 18 | :when (not= a1 a2)] 19 | (let [c (create-vertex! g 'Const)] 20 | (set-value! c :value (eval-exp b)) 21 | (relink! b c nil :in)) 22 | (g/delete! [b a1 a2])) 23 | 24 | (deftest test-replace-binops 25 | (let [tree (bin-tree)] 26 | (is (== 4 ((iterated-rule replace-binaryop) tree))) 27 | (is (== 1 (vcount tree))) 28 | (is (== 0 (ecount tree))) 29 | (is (== 1.65 (value (q/the (vseq tree)) :value))))) 30 | 31 | (deftest test-replace-binops2 32 | (let [tree (bin-tree)] 33 | (is (== 4 ((iterated-rule 34 | ;; Also try with an anonymous rule 35 | (rule [g] 36 | [b --> a1 37 | b --> a2 38 | :when (not= a1 a2)] 39 | (let [c (create-vertex! g 'Const)] 40 | (set-value! c :value (eval-exp b)) 41 | (relink! b c nil :in)) 42 | (g/delete! [b a1 a2]))) 43 | tree))) 44 | (is (== 1 (vcount tree))) 45 | (is (== 0 (ecount tree))) 46 | (is (== 1.65 (value (q/the (vseq tree)) :value))))) 47 | 48 | (deftest test-replace-binops3 49 | (let [tree (bin-tree)] 50 | (is (== 4 ((iterated-rule 51 | ;; Also try with an anonymous rule with a label and more than 52 | ;; one sig. 53 | (rule foo 54 | ([g x] [x --> y] 55 | (throw (RuntimeException. "Must not have happened."))) 56 | ([g] 57 | [b --> a1 58 | b --> a2 59 | :when (not= a1 a2)] 60 | (let [c (create-vertex! g 'Const)] 61 | (set-value! c :value (eval-exp b)) 62 | (relink! b c nil :in)) 63 | (g/delete! [b a1 a2])))) 64 | tree))) 65 | (is (== 1 (vcount tree))) 66 | (is (== 0 (ecount tree))) 67 | (is (== 1.65 (value (q/the (vseq tree)) :value))))) 68 | 69 | (deftest test-replace-binops4 70 | (let [tree (bin-tree)] 71 | (letrule [(repl-bin-op 72 | [g] [b --> a1 73 | b --> a2 74 | :when (not= a1 a2)] 75 | (let [c (create-vertex! g 'Const)] 76 | (set-value! c :value (eval-exp b)) 77 | (relink! b c nil :in)) 78 | (g/delete! [b a1 a2]))] 79 | (is (== 4 ((iterated-rule repl-bin-op) tree))) 80 | (is (== 1 (vcount tree))) 81 | (is (== 0 (ecount tree))) 82 | (is (== 1.65 (value (q/the (vseq tree)) :value)))))) 83 | 84 | (deftest test-replace-binops5 85 | (let [tree (bin-tree)] 86 | (letrule [(repl-bin-op 87 | ([g x] [x --> y] 88 | (throw (RuntimeException. "Must not have happened."))) 89 | ([g] [b --> a1 90 | b --> a2 91 | :when (not= a1 a2)] 92 | (let [c (create-vertex! g 'Const)] 93 | (set-value! c :value (eval-exp b)) 94 | (relink! b c nil :in)) 95 | (g/delete! [b a1 a2])))] 96 | (is (== 4 ((iterated-rule repl-bin-op) tree))) 97 | (is (== 1 (vcount tree))) 98 | (is (== 0 (ecount tree))) 99 | (is (== 1.65 (value (q/the (vseq tree)) :value)))))) 100 | 101 | (defn ^:private counter-graph [digits] 102 | (let [s (load-schema "test/input/counter-schema.tg") 103 | g (new-graph s)] 104 | (dotimes [i digits] 105 | (let [h (tg/create-vertex! g 'Digit {:val i})] 106 | (when-not (zero? i) 107 | (create-edge! g 'HasNext (tg/prev-vertex h) h)))) 108 | (create-edge! g 'HasNext (tg/last-vertex g) (tg/first-vertex g)) 109 | (let [c (tg/create-vertex! g 'Counter)] 110 | (create-edge! g 'HasPrimaryDigit c (tg/vertex g 1)) 111 | (create-edge! g 'HasSecondaryDigit c (tg/vertex g 1))) 112 | g)) 113 | 114 | (defrule tick-forward [g] 115 | [c -sec<:secondary>-> <> --> next 116 | :alternative [[:when (not (zero? (tg/value next :val)))] 117 | [:when (zero? (tg/value next :val)) 118 | c -prim<:primary>-> <> --> next2]]] 119 | (when prim 120 | (tg/set-omega! prim next2)) 121 | (tg/set-omega! sec next)) 122 | 123 | (defrule tick-backward [g] 124 | [c -sec<:secondary>-> cur <-- prev 125 | :alternative [[:when (not (zero? (tg/value cur :val)))] 126 | [:when (zero? (tg/value cur :val)) 127 | c -prim<:primary>-> <> <-- prev2]]] 128 | (when prim 129 | (tg/set-omega! prim prev2)) 130 | (tg/set-omega! sec prev)) 131 | 132 | (defrule reset-counter [g] 133 | [c -<:secondary>-> d1 134 | c -<:primary>-> d2 135 | :when (or (not (zero? (tg/value d1 :val))) 136 | (not (zero? (tg/value d2 :val))))] 137 | (let [digit-zero (q/the #(zero? (tg/value % :val)) 138 | (tg/vseq g 'Digit))] 139 | (g/set-adj! c :secondary digit-zero) 140 | (g/set-adj! c :primary digit-zero))) 141 | 142 | (defrule erase-clock-hands [g] 143 | [c -p<:primary>-> <> 144 | c -s<:secondary>-> <>] 145 | (g/delete! p) 146 | (g/delete! s)) 147 | 148 | (defn exactly-two-clock-hands? [cg] 149 | (and (= 1 (tg/ecount cg 'HasPrimaryDigit)) 150 | (= 1 (tg/ecount cg 'HasSecondaryDigit)))) 151 | 152 | (defn counter-at-0:0? [old-model match new-model] 153 | (let [val-of (fn [ec] 154 | (tg/value (tg/omega (q/the (tg/eseq new-model ec))) 155 | :val))] 156 | (and (= 0 (val-of 'HasPrimaryDigit)) 157 | (= 0 (val-of 'HasSecondaryDigit))))) 158 | 159 | (defn at-most-9-states? [ssg] 160 | (<= (vcount ssg) 9)) 161 | 162 | (deftest test-create-state-space-1 163 | (let [g (counter-graph 3) 164 | [ssg s2m ret] (create-state-space g 165 | #(g/equal-models? %1 %2 false) 166 | [tick-forward tick-backward] 167 | {:state-preds [exactly-two-clock-hands?] 168 | :state-space-preds [at-most-9-states?]})] 169 | (is (= 9 (vcount ssg 'State))) 170 | (is (= 18 (ecount ssg 'Transition))) 171 | (is (false? ret)))) 172 | 173 | (deftest test-create-state-space-2 174 | (let [g (counter-graph 3) 175 | [ssg s2m ret] (create-state-space 176 | g 177 | #(g/equal-models? %1 %2 false) 178 | [tick-forward tick-backward reset-counter] 179 | {:state-preds [exactly-two-clock-hands?] 180 | :transition-preds {reset-counter [counter-at-0:0?]} 181 | :state-space-preds [at-most-9-states?]})] 182 | (is (= 9 (vcount ssg 'State))) 183 | ;; 26, not 27, because reset-counter doesn't match in the 0:0 case. 184 | (is (= 26 (ecount ssg 'Transition))) 185 | (is (false? ret)))) 186 | 187 | (defn test-explore-state-space [] 188 | (let [g (counter-graph 3)] 189 | (explore-state-space 190 | g 191 | #(g/equal-models? %1 %2 false) 192 | [tick-forward tick-backward reset-counter erase-clock-hands] 193 | {:state-preds [exactly-two-clock-hands?] 194 | :transition-preds {reset-counter [counter-at-0:0?]} 195 | :state-space-preds [at-most-9-states?]}))) 196 | -------------------------------------------------------------------------------- /test/funnyqt/in_place_test.clj: -------------------------------------------------------------------------------- 1 | (ns funnyqt.in-place-test 2 | (:use funnyqt.in-place)) 3 | 4 | ;; TODO: Write tests! 5 | 6 | -------------------------------------------------------------------------------- /test/funnyqt/misc_tests/classhierarchy2documents.clj: -------------------------------------------------------------------------------- 1 | (ns funnyqt.misc-tests.classhierarchy2documents 2 | (:require [funnyqt.query :as q] 3 | [funnyqt.generic :as g] 4 | [funnyqt.visualization :as v] 5 | [funnyqt.tg :as tg] 6 | [funnyqt.relational :as r] 7 | [funnyqt.bidi :refer :all] 8 | [clojure.core.logic :as ccl] 9 | [clojure.test :as test])) 10 | 11 | (r/generate-metamodel-relations "test/input/classhierarchy.tg" test.classhierarchyschema c) 12 | (r/generate-metamodel-relations "test/input/documents.tg" test.documentschema d) 13 | 14 | (defn sample-class-graph [] 15 | (let [g (tg/new-graph (tg/load-schema "test/input/classhierarchy.tg")) 16 | obj (doto (tg/create-vertex! g 'Class) 17 | (tg/set-value! :name "Object")) 18 | obs (doto (tg/create-vertex! g 'Class) 19 | (tg/set-value! :name "Observable")) 20 | ser (doto (tg/create-vertex! g 'Class) 21 | (tg/set-value! :name "Serializable")) 22 | per (doto (tg/create-vertex! g 'Class) 23 | (tg/set-value! :name "Person")) 24 | employer (doto (tg/create-vertex! g 'Class) 25 | (tg/set-value! :name "Employer")) 26 | employee (doto (tg/create-vertex! g 'Class) 27 | (tg/set-value! :name "Employee")) 28 | subemployee (doto (tg/create-vertex! g 'Class) 29 | (tg/set-value! :name "SubEmployee"))] 30 | (tg/create-edge! g 'HasSuperClass obs obj) 31 | (tg/create-edge! g 'HasSuperClass ser obj) 32 | (tg/create-edge! g 'HasSuperClass per obs) 33 | (tg/create-edge! g 'HasSuperClass per ser) 34 | (tg/create-edge! g 'HasSuperClass employer per) 35 | (tg/create-edge! g 'HasSuperClass employee per) 36 | (tg/create-edge! g 'HasSuperClass subemployee employee) 37 | g)) 38 | 39 | ;; (v/print-model (sample-class-graph) :gtk) 40 | 41 | (deftransformation classhierarchy2documents [classes docs] 42 | (^:top class2doc 43 | :left [(c/Class classes ?c) 44 | (c/name classes ?c ?name)] 45 | :right [(d/Document docs ?d) 46 | (d/name docs ?d ?name)]) 47 | (^:top generalization2directlinks 48 | :when [(class2doc :?c ?subclass :?d ?srcdoc) 49 | (class2doc :?c ?superclass :?d ?trgdoc)] 50 | :left [(c/->superclasses classes ?subclass ?superclass)] 51 | :right [(d/->trgs docs ?srcdoc ?trgdoc)]) 52 | (transitive-linko [a b] 53 | (ccl/conde 54 | [(generalization2directlinks :?srcdoc a :?trgdoc b)] 55 | [(ccl/fresh [x] 56 | (generalization2directlinks :?srcdoc a :?trgdoc x) 57 | (transitive-linko x b))])) 58 | (^:top generalization2transitivelinks 59 | :when [(transitive-linko ?a ?b)] 60 | :right [(d/->alltrgs docs ?a ?b)])) 61 | 62 | (defn doc-by-name [docs name] 63 | (q/the #(= name (tg/value % :name)) 64 | (tg/vseq docs 'Document))) 65 | 66 | (defn assert-all-trgs [d src & trgs] 67 | (test/is (= (set (map (partial doc-by-name d) trgs)) 68 | (set (g/adjs (doc-by-name d src) :alltrgs))))) 69 | 70 | (test/deftest test-classhierarchy2documents 71 | (let [c (sample-class-graph) 72 | d (tg/new-graph (tg/load-schema "test/input/documents.tg")) 73 | c2 (tg/new-graph (tg/schema c))] 74 | (classhierarchy2documents c d :right) 75 | (assert-all-trgs d "SubEmployee" "Employee" "Person" "Observable" "Serializable" "Object") 76 | (assert-all-trgs d "Employee" "Person" "Observable" "Serializable" "Object") 77 | (assert-all-trgs d "Employer" "Person" "Observable" "Serializable" "Object") 78 | (assert-all-trgs d "Person" "Observable" "Serializable" "Object") 79 | (assert-all-trgs d "Observable" "Object") 80 | (assert-all-trgs d "Serializable" "Object") 81 | ;;(v/print-model d :gtk) 82 | (classhierarchy2documents c2 d :left) 83 | ;;(v/print-model c2 :gtk) 84 | (test/is (g/equal-models? c c2)))) 85 | -------------------------------------------------------------------------------- /test/funnyqt/misc_tests/mutual_exclusion_emf.clj: -------------------------------------------------------------------------------- 1 | (ns ^{:pattern-expansion-context :emf} 2 | funnyqt.misc-tests.mutual-exclusion-emf 3 | (:require [clojure.test :refer :all] 4 | [funnyqt 5 | [emf :refer :all] 6 | [generic :refer :all] 7 | [in-place :refer :all] 8 | [query :as q] 9 | [utils :refer :all]])) 10 | 11 | (load-ecore-resource "test/input/MutualExclusion.ecore") 12 | 13 | ;;* Rules 14 | 15 | ;;** Short Transformation Sequence 16 | 17 | (def counter (atom 1)) 18 | 19 | (defrule new-rule 20 | "Matches 2 connected processes and adds a new process in between." 21 | [model] [p1 -<:next>-> p2 22 | :isomorphic] 23 | (let [p (ecreate! model 'Process)] 24 | (eset! p :name (str "np" @counter)) 25 | (swap! counter inc) 26 | (eset! p1 :next p) 27 | (eset! p :next p2))) 28 | 29 | (defrule kill-rule 30 | "Matches a sequence of 3 connected processes and deletes the middle one." 31 | [model] [p1 -<:next>-> p -<:next>-> p2 32 | :isomorphic] 33 | (delete! p) 34 | (eset! p1 :next p2)) 35 | 36 | (defrule mount-rule 37 | "Matches a process and creates and assigns a resource to it." 38 | [model] [p] 39 | (let [r (ecreate! model 'Resource)] 40 | (eset! r :name (str "nr" @counter)) 41 | (swap! counter inc) 42 | (eset! r :taker p))) 43 | 44 | (defrule unmount-rule 45 | "Matches a resource assigned to a process and deletes it." 46 | [model] [r -<:taker>-> p] 47 | (delete! r)) 48 | 49 | (defrule pass-rule 50 | "Passes the token to the next process if the current doesn't request it." 51 | [model] [r -<:taker>-> p1 -!<:requested>-> r 52 | p1 -<:next>-> p2] 53 | (eset! r :taker p2)) 54 | 55 | (defrule request-rule 56 | "Matches a process that doesn't request any resource and a resource not held 57 | by that process and makes the process request that resource." 58 | [model] [r -!<:holder>-> p -!<:requested>-> <>] 59 | (eadd! p :requested r)) 60 | 61 | (defrule take-rule 62 | "Matches a process that requests a resource that in turn tokens the process 63 | and makes the process hold that resource." 64 | ([model] [p -<:requested>-> r -<:taker>-> p] 65 | (take-rule model r p)) 66 | ([model r p] 67 | (eunset! r :taker) 68 | (eremove! r :requester p) 69 | (eset! r :holder p) 70 | [r p])) 71 | 72 | (defrule release-rule 73 | "Matches a resource held by a process and not requesting more resources, and 74 | releases that resource." 75 | ([model] [r -<:holder>-> p -!<:requested>-> <>] 76 | (release-rule model r p)) 77 | ([model r p] 78 | (eunset! r :holder) 79 | (eset! r :releaser p) 80 | [r p])) 81 | 82 | (defrule give-rule 83 | "Matches a process releasing a resource, and gives the token to that resource 84 | to the next process." 85 | ([model] [r -<:releaser>-> p1 -<:next>-> p2] 86 | (give-rule model r p1)) 87 | ([model r p1] 88 | (let [p2 (eget p1 :next)] 89 | (eunset! r :releaser) 90 | (eset! r :taker p2) 91 | [r p2]))) 92 | 93 | (defrule blocked-rule 94 | "Matches a process requesting a resource held by some other process, and 95 | creates a blocked edge." 96 | [model] [p1 -<:requested>-> r -<:holder>-> p2 97 | :isomorphic] 98 | (eadd! r :blocked p1)) 99 | 100 | (defrule waiting-rule 101 | "Moves the blocked state." 102 | ([model] [p2 -<:requested>-> r1 -<:holder>-> p1 -<:blocked_by>-> r2 103 | :isomorphic] 104 | (waiting-rule model r1 r2 p1 p2)) 105 | ([model r1] [r1 -<:requester>-> p2 106 | r1 -<:holder>-> p1 -<:blocked_by>-> r2 107 | :isomorphic] 108 | (waiting-rule model r1 r2 p1 p2)) 109 | ([model r1 r2 p1 p2] 110 | (eremove! r2 :blocked p1) 111 | (eadd! r2 :blocked p2) 112 | [model r1])) 113 | 114 | (defrule ignore-rule 115 | "Removes the blocked state if nothing is held anymore." 116 | [model] [r -<:blocked>-> p -!<:held>-> <>] 117 | (eremove! r :blocked p)) 118 | 119 | (defrule unlock-rule 120 | "Matches a process holding and blocking a resource and releases it." 121 | [model] [r -<:holder>-> p -<:blocked_by>-> r] 122 | (eunset! r :holder) 123 | (eremove! r :blocked p) 124 | (eset! r :releaser p)) 125 | 126 | (defn apply-mutual-exclusion-sts 127 | "Does the STS on `m`." 128 | [m n param-pass] 129 | ;; n-2 times new-rule ==> n processes in a ring 130 | (dotimes [_ (- n 2)] 131 | (new-rule m)) 132 | ;; mount a resource and give token to one process 133 | (mount-rule m) 134 | ;; Let all processe issue a request to the single resource 135 | (dotimes [_ n] 136 | (request-rule m)) 137 | ;; Handle the requests... 138 | (if param-pass 139 | ((iterated-rule #(apply give-rule m (apply release-rule m (take-rule m))))) 140 | ((iterated-rule #(do 141 | (take-rule m) 142 | (release-rule m) 143 | (give-rule m)))))) 144 | 145 | (defn g-sts 146 | "Returns an initial graph for the STS. 147 | Two Processes connected in a ring by two Next edges." 148 | [] 149 | (let [m (new-resource) 150 | p1 (ecreate! m 'Process) 151 | p2 (ecreate! m 'Process)] 152 | (eset! p1 :name "p1") 153 | (eset! p2 :name "p2") 154 | (eset! p1 :next p2) 155 | (eset! p2 :next p1) 156 | m)) 157 | 158 | 159 | ;;** Long Transformation Sequence 160 | 161 | (defrule request-star-rule 162 | "Matches a process and its successor that hold two different resources, and 163 | makes the successor request its predecessor's resource." 164 | [model] [r1 -<:holder>-> p1 -<:prev>-> p2 -<:held>-> r2 165 | p1 -!<:requested>-> r2 166 | :isomorphic] 167 | (eadd! p1 :requested r2)) 168 | 169 | (defrule release-star-rule 170 | "Matches a process holding 2 resources where one is requested by another 171 | process, and releases the requested one." 172 | ([model] [p1 -<:requested>-> r1 -<:holder>-> p2 -<:held>-> r2 173 | :isomorphic] 174 | (eunset! r1 :holder) 175 | (eset! r1 :releaser p2)) 176 | ([model r2 p2] [p2 -<:held>-> r1 -<:requester>-> p1 :isomorphic] 177 | (eunset! r1 :holder) 178 | (eset! r1 :releaser p2))) 179 | 180 | 181 | (defn apply-mutual-exclusion-lts 182 | "Performs the LTS transformation." 183 | [model n param-pass] 184 | ;; The main entry point 185 | (let [cnt (atom 0)] 186 | (dotimes [_ n] 187 | (request-star-rule model)) 188 | (blocked-rule model) 189 | (dotimes [_ (dec n)] 190 | (waiting-rule model)) 191 | (unlock-rule model) 192 | (blocked-rule model) 193 | (if param-pass 194 | ((iterated-rule #(or ((iterated-rule* waiting-rule) model) 195 | (waiting-rule model)))) 196 | ((iterated-rule waiting-rule) model)) 197 | (ignore-rule model) 198 | (if param-pass 199 | ((iterated-rule #(apply release-star-rule model 200 | (apply take-rule model 201 | (give-rule model))))) 202 | ((iterated-rule (sequential-rule 203 | give-rule take-rule release-star-rule)) 204 | model)) 205 | (give-rule model) 206 | (take-rule model))) 207 | 208 | (defn g-lts 209 | "Returns an initial graph for the LTS. 210 | n processes and n resources. 211 | n Next edges organize the processes in a token ring. 212 | n HeldBy edges assign to each process a resource." 213 | [n] 214 | (let [m (new-resource)] 215 | (loop [i n, lp nil] 216 | (if (pos? i) 217 | (let [r (ecreate! m 'Resource) 218 | p (ecreate! m 'Process)] 219 | (when lp 220 | (eset! lp :next p)) 221 | (eset! p :name (str "p" (- (inc n) i))) 222 | (eset! r :name (str "r" (- (inc n) i))) 223 | (eset! r :holder p) 224 | (recur (dec i) p)) 225 | (eset! lp :next (first (econtents m 'Process))))) 226 | m)) 227 | 228 | 229 | ;;* Tests 230 | 231 | (deftest mutual-exclusion-sts 232 | (println) 233 | (println "Mutual Exclusion STS") 234 | (println "====================") 235 | (doseq [n [5, 100, 500]] 236 | (let [g1 (g-sts) 237 | g2 (g-sts)] 238 | (println "N =" n) 239 | (print " without parameter passing:\t") 240 | (time (apply-mutual-exclusion-sts g1 n false)) 241 | (is (= (inc n) (count (eallcontents g1)))) 242 | (is (= (inc n) (count (ecrosspairs g1)))) 243 | ;;(print-model g1 ".gtk") 244 | 245 | (print " with parameter passing:\t") 246 | (time (apply-mutual-exclusion-sts g2 n true)) 247 | (is (= (inc n) (count (eallcontents g2)))) 248 | (is (= (inc n) (count (ecrosspairs g2)))) 249 | ;;(print-model g2 ".gtk") 250 | ))) 251 | 252 | (deftest mutual-exclusion-lts 253 | (println) 254 | (println "Mutual Exclusion LTS") 255 | (println "====================") 256 | (doseq [[n r vc ec] [[4 100 8 8] 257 | [1000 1 2000 2000]]] 258 | (let [g1 (g-lts n) 259 | g2 (g-lts n)] 260 | (println "N =" n ", R =" r) 261 | 262 | (print " without parameter passing:\t") 263 | (time (dotimes [_ r] (apply-mutual-exclusion-lts g1 n false))) 264 | #_(print-model g1 ".gtk") 265 | (is (= vc (count (eallcontents g1)))) 266 | (is (= ec (count (ecrosspairs g1)))) 267 | 268 | 269 | (print " with parameter passing:\t") 270 | (time (dotimes [_ r] (apply-mutual-exclusion-lts g2 n true))) 271 | (is (= vc (count (eallcontents g2)))) 272 | (is (= ec (count (ecrosspairs g2))))))) 273 | 274 | -------------------------------------------------------------------------------- /test/funnyqt/misc_tests/mutual_exclusion_tg.clj: -------------------------------------------------------------------------------- 1 | (ns ^{:pattern-expansion-context :tg} 2 | funnyqt.misc-tests.mutual-exclusion-tg 3 | (:require [clojure.test :refer :all] 4 | [funnyqt 5 | [generic :as g] 6 | [in-place :refer :all] 7 | [tg :refer :all] 8 | [utils :refer :all]])) 9 | 10 | ;;* Rules 11 | 12 | ;;** Short Transformation Sequence 13 | 14 | (defrule new-rule 15 | "Matches 2 connected processes and injects a new process in between." 16 | [g] [p1 -n-> p2 17 | :isomorphic] 18 | (let [p (create-vertex! g 'Process)] 19 | (set-omega! n p) 20 | (create-edge! g 'Next p p2))) 21 | 22 | (defrule kill-rule 23 | "Matches a sequence of 3 connected processes and deletes the middle one." 24 | [g] [p1 -n1-> p -n2-> p2 25 | :isomorphic] 26 | (set-omega! n1 p2) 27 | (g/delete! p)) 28 | 29 | (defrule mount-rule 30 | "Matches a process and creates and assigns a resource to it." 31 | [g] [p] 32 | (create-edge! g 'Token (create-vertex! g 'Resource) p)) 33 | 34 | (defrule unmount-rule 35 | "Matches a resource assigned to a process and deletes it." 36 | [g] [r -t-> p] 37 | (g/delete! r)) 38 | 39 | (defrule pass-rule 40 | "Passes the token to the next process if the current doesn't request it." 41 | [g] [r -t-> p1 -!-> r 42 | p1 -n-> p2] 43 | (set-omega! t p2)) 44 | 45 | (defrule request-rule 46 | "Matches a process that doesn't request any resource and a resource not held 47 | by that process and makes the process request that resource." 48 | [g] [r -!-> p -!-> <>] 49 | (create-edge! g 'Request p r)) 50 | 51 | (defrule take-rule 52 | "Matches a process that requests a resource that in turn tokens the process 53 | and makes the process hold that resource." 54 | ([g] [p -rq-> r -t-> p] 55 | (take-rule g r t p rq)) 56 | ([g r t p] [p -rq-> r] 57 | (take-rule g r t p rq)) 58 | ([g r t p rq] 59 | (g/delete! [t rq]) 60 | ;; Return a vec of the resource, HeldBy and process for param passing 61 | [r (create-edge! g 'HeldBy r p) p])) 62 | 63 | (defrule release-rule 64 | "Matches a resource holding a resource and not requesting more resources, and 65 | releases that resource." 66 | ([g] [r -hb-> p -!-> <>] 67 | (release-rule g r hb p)) 68 | ([g r hb p] 69 | (g/delete! hb) 70 | [r (create-edge! g 'Release r p) p])) 71 | 72 | (defrule give-rule 73 | "Matches a process releasing a resource, and gives the token to that resource 74 | to the next process." 75 | ([g] [r -rel-> p1 -n-> p2] 76 | (give-rule g r rel p1 n p2)) 77 | ([g r rel p1] [p1 -n-> p2] 78 | (give-rule g r rel p1 n p2)) 79 | ([g r rel p1 n p2] 80 | (g/delete! rel) 81 | [r (create-edge! g 'Token r p2) p2])) 82 | 83 | (defrule blocked-rule 84 | "Matches a process requesting a resource held by some other process, and 85 | creates a blocked edge." 86 | [g] [p1 -req-> r -hb-> p2 87 | :isomorphic] 88 | (create-edge! g 'Blocked r p1)) 89 | 90 | (defrule waiting-rule 91 | "Moves the blocked state." 92 | ([g] [p2 -req-> r1 -hb-> 93 | p1 <-b- r2 94 | :isomorphic] 95 | (waiting-rule g r1 b p2)) 96 | ([g r1] [r1 <-req- p2 97 | r1 -hb-> p1 <-b- r2 98 | :isomorphic] 99 | (waiting-rule g r1 b p2)) 100 | ([g r1 b p2] 101 | (set-omega! b p2) 102 | [g r1])) 103 | 104 | 105 | (defrule ignore-rule 106 | "Removes the blocked state if nothing is held anymore." 107 | [g] [r -b-> p 108 | :when (empty? (iseq p 'HeldBy))] 109 | (g/delete! b)) 110 | 111 | (defrule unlock-rule 112 | "Matches a process holding and blocking a resource and releases it." 113 | [g] [r -hb-> p <-b- r] 114 | (g/delete! [hb b]) 115 | (create-edge! g 'Release r p)) 116 | 117 | (defn apply-mutual-exclusion-sts 118 | [g n param-pass] 119 | ;; n-2 times new-rule ==> n processes in a ring 120 | (dotimes [_ (- n 2)] 121 | (new-rule g)) 122 | ;; mount a resource and give token to one process 123 | (mount-rule g) 124 | ;; Let all processe issue a request to the single resource 125 | (dotimes [_ n] 126 | (request-rule g)) 127 | ;; Handle the requests... 128 | (if param-pass 129 | ((iterated-rule #(apply give-rule g (apply release-rule g (take-rule g))))) 130 | ((iterated-rule #(do 131 | (take-rule g) 132 | (release-rule g) 133 | (give-rule g)))))) 134 | 135 | (defn g-sts 136 | "Returns an initial graph for the STS. 137 | Two Processes connected in a ring by two Next edges." 138 | [] 139 | (let [g (new-graph (load-schema "test/input/mutual-exclusion-schema.tg") 140 | "Short transformation sequence.") 141 | p1 (create-vertex! g 'Process) 142 | p2 (create-vertex! g 'Process)] 143 | (create-edge! g 'Next p1 p2) 144 | (create-edge! g 'Next p2 p1) 145 | g)) 146 | 147 | ;;** Long Transformation Sequence 148 | 149 | (defrule request-star-rule 150 | "Matches a process and its successor that hold two different resources, and 151 | makes the successor request its predecessor's resource." 152 | [g] [r1 -h1-> p1 <-- p2 <-h2- r2 153 | p1 -!-> r2 154 | :isomorphic] 155 | (create-edge! g 'Request p1 r2)) 156 | 157 | (defrule release-star-rule 158 | "Matches a process holding 2 resources where one is requested by another 159 | process, and releases the requested one." 160 | ([g] [p1 -rq-> r1 -h1-> p2 <-h2- r2 161 | :isomorphic] 162 | (release-star-rule g r2 h2 p2 h1 r1 rq p1)) 163 | ([g r2 h2 p2] [p2 <-h1<_>- r1 <-rq- p1 :isomorphic] 164 | (release-star-rule g r2 h2 p2 h1 r1 rq p1)) 165 | ([g r2 h2 p2 h1 r1 rq p1] 166 | (g/delete! h1) 167 | (create-edge! g 'Release r1 p2))) 168 | 169 | (defn apply-mutual-exclusion-lts 170 | [g n param-pass] 171 | (dotimes [_ n] 172 | (request-star-rule g)) 173 | (blocked-rule g) 174 | (dotimes [_ (dec n)] 175 | (waiting-rule g)) 176 | (unlock-rule g) 177 | (blocked-rule g) 178 | (if param-pass 179 | ((iterated-rule #(or ((iterated-rule* waiting-rule) g) 180 | (waiting-rule g)))) 181 | ((iterated-rule #(waiting-rule g)))) 182 | (ignore-rule g) 183 | (if param-pass 184 | ((iterated-rule #(apply release-star-rule % (apply take-rule % (give-rule %)))) g) 185 | ((iterated-rule (sequential-rule give-rule take-rule release-star-rule)) g)) 186 | (give-rule g) 187 | (take-rule g)) 188 | 189 | (defn g-lts 190 | "Returns an initial graph for the LTS. 191 | n processes and n resources. 192 | n Next edges organize the processes in a token ring. 193 | n HeldBy edges assign to each process a resource." 194 | [n] 195 | (let [g (new-graph (load-schema "test/input/mutual-exclusion-schema.tg") 196 | (str "Long transformation sequence, N =" n))] 197 | (loop [i n, lp nil] 198 | (if (pos? i) 199 | (let [r (create-vertex! g 'Resource) 200 | p (create-vertex! g 'Process)] 201 | (when lp 202 | (create-edge! g 'Next lp p)) 203 | (create-edge! g 'HeldBy r p) 204 | (recur (dec i) p)) 205 | (create-edge! g 'Next lp (first (vseq g 'Process))))) 206 | g)) 207 | 208 | 209 | ;;* Tests 210 | 211 | (deftest mutual-exclusion-sts 212 | (println) 213 | (println "Mutual Exclusion STS") 214 | (println "====================") 215 | (doseq [n [5, 100, 500]] 216 | (let [g1 (g-sts) 217 | g2 (g-sts)] 218 | (println "N =" n) 219 | (print " without parameter passing:\t") 220 | (time (apply-mutual-exclusion-sts g1 n false)) 221 | (is (= (inc n) (vcount g1))) 222 | (is (= (inc n) (ecount g1))) 223 | 224 | (print " with parameter passing:\t") 225 | (time (apply-mutual-exclusion-sts g2 n true)) 226 | (is (= (inc n) (vcount g2))) 227 | (is (= (inc n) (ecount g2)))))) 228 | 229 | (deftest mutual-exclusion-lts 230 | (println) 231 | (println "Mutual Exclusion LTS") 232 | (println "====================") 233 | ;; vc and ec are the expected values 234 | (doseq [[n r vc ec] [[4 100 8 8] 235 | [1000 1 2000 2000]]] 236 | (let [g1 (g-lts n) 237 | g2 (g-lts n)] 238 | (println "N =" n ", R =" r) 239 | (print " without parameter passing:\t") 240 | (time (dotimes [_ r] (apply-mutual-exclusion-lts g1 n false))) 241 | (is (= vc (vcount g1))) 242 | (is (= ec (ecount g1))) 243 | 244 | (print " with parameter passing:\t") 245 | (time (dotimes [_ r] (apply-mutual-exclusion-lts g2 n true))) 246 | (is (= vc (vcount g2))) 247 | (is (= ec (ecount g2)))))) 248 | 249 | (defn test-interactive-rule [] 250 | ((interactive-rule 251 | new-rule kill-rule mount-rule unmount-rule pass-rule request-rule 252 | take-rule release-rule give-rule blocked-rule waiting-rule 253 | ignore-rule unlock-rule request-star-rule release-star-rule) 254 | (g-lts 4))) 255 | -------------------------------------------------------------------------------- /test/funnyqt/misc_tests/sierpinski_tg.clj: -------------------------------------------------------------------------------- 1 | (ns ^{:pattern-expansion-context :tg} 2 | funnyqt.misc-tests.sierpinski-tg 3 | (:require [clojure.test :refer :all] 4 | [funnyqt 5 | [tg :refer :all] 6 | [in-place :refer :all]])) 7 | 8 | (defn sierpinski-init 9 | "Returns a sierpienki triangle." 10 | [vc ec] 11 | (let [g (new-graph (load-schema "test/input/sierpinski-schema.tg" :standard) 12 | "Sierpinski" :standard) 13 | t (create-vertex! g 'V) 14 | l (create-vertex! g 'V) 15 | r (create-vertex! g 'V)] 16 | (create-edge! g 'L t l) 17 | (create-edge! g 'R t r) 18 | (create-edge! g 'B l r) 19 | g)) 20 | 21 | (defrule triangulate 22 | "triangulate one trinangle" 23 | [g lv b rv] [lv <-l- tv 24 | rv <-r- tv] 25 | (let [nl (create-vertex! g 'V) 26 | nr (create-vertex! g 'V) 27 | nb (create-vertex! g 'V)] 28 | (set-omega! l nl) 29 | (set-omega! r nr) 30 | (set-omega! b nb) 31 | 32 | (create-edge! g 'L nl lv) 33 | (create-edge! g 'R nr rv) 34 | (create-edge! g 'B nb rv) 35 | 36 | (create-edge! g 'L nr nb) 37 | (create-edge! g 'R nl nb) 38 | (create-edge! g 'B nl nr))) 39 | 40 | (defn triangulate-sequential 41 | [g] 42 | (doseq [b (doall (eseq g 'B))] 43 | (triangulate g (alpha b) b (omega b)))) 44 | 45 | (defrule triangulate-recursively 46 | "triangulate all recursively" 47 | ([g] [:for [tv (filter #(empty? (iseq % 'B)) (vseq g))]] 48 | (triangulate-recursively g tv)) 49 | ([g tv] [tv -l-> lv 50 | tv -r-> rv 51 | lv -b-> rv] 52 | (let [nlv (create-vertex! g 'V) 53 | nrv (create-vertex! g 'V) 54 | nbv (create-vertex! g 'V)] 55 | (set-omega! l nlv) 56 | (set-omega! r nrv) 57 | (set-omega! b nbv) 58 | 59 | (create-edge! g 'L nlv lv) 60 | (create-edge! g 'R nrv rv) 61 | (create-edge! g 'B nbv rv) 62 | 63 | (create-edge! g 'L nrv nbv) 64 | (create-edge! g 'R nlv nbv) 65 | (create-edge! g 'B nlv nrv) 66 | (triangulate-recursively g lv) 67 | (triangulate-recursively g rv)))) 68 | 69 | (defrule triangulate-trampolined 70 | "triangulate all recursively" 71 | ([g] [:for [tv (filter #(empty? (iseq % 'B)) (vseq g))]] 72 | (triangulate-trampolined g tv)) 73 | ([g tv] [tv -l-> lv 74 | tv -r-> rv 75 | lv -b-> rv] 76 | (let [nlv (create-vertex! g 'V) 77 | nrv (create-vertex! g 'V) 78 | nbv (create-vertex! g 'V)] 79 | (set-omega! l nlv) 80 | (set-omega! r nrv) 81 | (set-omega! b nbv) 82 | 83 | (create-edge! g 'L nlv lv) 84 | (create-edge! g 'R nrv rv) 85 | (create-edge! g 'B nbv rv) 86 | 87 | (create-edge! g 'L nrv nbv) 88 | (create-edge! g 'R nlv nbv) 89 | (create-edge! g 'B nlv nrv) 90 | (fn [] 91 | (triangulate-recursively g lv) 92 | (triangulate-recursively g rv))))) 93 | 94 | (defn impl-label [g] 95 | (if (instance? de.uni_koblenz.jgralab.impl.generic.GenericGraphImpl g) 96 | "gen" 97 | "std")) 98 | 99 | (defn run 100 | [g f title n correct-vc correct-ec] 101 | (print (format " ==> %s (%s): " title (impl-label g))) 102 | (time (dotimes [_ n] (f g))) 103 | (let [vc (vcount g), ec (ecount g)] 104 | (is (== correct-vc vc)) 105 | (is (== correct-ec ec)))) 106 | 107 | (deftest sierpinski 108 | (println "Sierpinski Triangles") 109 | (println "====================") 110 | (doseq [n (range 8 12)] 111 | (let [correct-vc (int (* 3/2 (inc (Math/pow 3 n)))) 112 | correct-ec (int (Math/pow 3 (inc n)))] 113 | (System/gc) 114 | (println (format "No. of generations: %s (%s vertices, %s edges)" 115 | n correct-vc correct-ec)) 116 | (run (sierpinski-init correct-vc correct-ec) 117 | #(triangulate-sequential %) 118 | "SEQUEN" n correct-vc correct-ec) 119 | (run (sierpinski-init correct-vc correct-ec) 120 | #(triangulate-recursively %) 121 | "RECURS" n correct-vc correct-ec) 122 | (run (sierpinski-init correct-vc correct-ec) 123 | #(trampoline (triangulate-trampolined %)) 124 | "TRAMPO" n correct-vc correct-ec)))) 125 | -------------------------------------------------------------------------------- /test/funnyqt/misc_tests/tree_tg.clj: -------------------------------------------------------------------------------- 1 | (ns ^{:pattern-expansion-context :tg} 2 | funnyqt.misc-tests.tree-tg 3 | (:require [clojure.test :refer :all] 4 | [funnyqt 5 | [in-place :refer :all] 6 | [tg :refer :all] 7 | [utils :refer :all]])) 8 | 9 | (defn mintree-init 10 | "Returns a mintree graph with one Tree vertex." 11 | [] 12 | (let [g (new-graph (load-schema "test/input/mintree-schema.tg") 13 | "MinTree")] 14 | (create-vertex! g 'Tree) 15 | g)) 16 | 17 | (defrule snoc 18 | "Creates a new Tree at the rightmost child. 19 | snoc = cons reversed. So we do like the tree was a singly linked list and 20 | always add at the end, which is of course a bad idea. 21 | Forces a complete iteration." 22 | [g] [t -!-> <>] 23 | (create-edge! g 'HasRight t (create-vertex! g 'Tree))) 24 | 25 | (defrule snoc-recursively 26 | "Recursive variant of snoc." 27 | ([g n] [t -!-> <> 28 | :when (pos? n)] 29 | (snoc-recursively g n t)) 30 | ([g n t] 31 | (when (pos? n) 32 | (let [nt (create-vertex! g 'Tree)] 33 | (create-edge! g 'HasRight t nt) 34 | (recur g (dec n) nt))))) 35 | 36 | (deftest test-snocs 37 | (dotimes [i 3] 38 | (let [g1 (mintree-init) 39 | g2 (mintree-init) 40 | n 1000] 41 | (timing "%s. SNOC SEQ: %Tmilli" ((repeated-rule n snoc) g1) (inc i)) 42 | (timing "%s. SNOC REC: %Tmilli" (snoc-recursively g2 n) (inc i)) 43 | 44 | (is (== (inc n) (vcount g1) (vcount g2))) 45 | (is (== n (ecount g1) (ecount g2)))))) 46 | -------------------------------------------------------------------------------- /test/funnyqt/model2model_test.clj: -------------------------------------------------------------------------------- 1 | (ns funnyqt.model2model-test 2 | (:require [clojure.test :refer :all] 3 | [funnyqt 4 | [emf :as emf] 5 | [generic :as g] 6 | [model2model :refer :all] 7 | [query :as q] 8 | [tg :refer :all]])) 9 | 10 | (emf/load-ecore-resource "test/input/Families.ecore") 11 | 12 | (defn family 13 | "Returns the main family of member m." 14 | [m] 15 | (or (g/adj m :familyFather) (g/adj m :familyMother) 16 | (g/adj m :familySon) (g/adj m :familyDaughter))) 17 | 18 | (defn male? 19 | "Returns true, iff member m is male." 20 | [m] 21 | (or (g/adj m :familyFather) (g/adj m :familySon))) 22 | 23 | (defn parents-of 24 | "Returns the set of parent members of m." 25 | [m] 26 | (q/p-seq m 27 | [q/p-alt :familySon :familyDaughter] 28 | [q/p-alt :father :mother])) 29 | 30 | (defn wife 31 | "Returns the wife member of member m." 32 | [m] 33 | (g/adj* m :familyFather :mother)) 34 | 35 | (generate-schema-functions "test/input/genealogy-schema.tg" 36 | test.functional.genealogy.tg 37 | gen-tg) 38 | 39 | (deftransformation families2genealogy 40 | "Transforms a family model to a genealogy model." 41 | [^:in in ^:out out] 42 | (first-name 43 | [m] 44 | (emf/eget m :firstName)) 45 | (make-address 46 | :from [street town] 47 | :to [adr 'Address {:street street 48 | :town town}] 49 | (is (= adr (resolve-in :make-address [street town])))) 50 | (^:top member2person 51 | :from [m] 52 | :disjuncts [member2male member2female :as p] 53 | (gen-tg/set-ageGroup! p (enum-constant p (if (< (emf/eget m :age) 18) 54 | 'AgeGroup.CHILD 55 | 'AgeGroup.ADULT))) 56 | (gen-tg/->set-address! p (make-address (emf/eget (family m) :street) 57 | (emf/eget (family m) :town))) 58 | (when-let [ps (seq (parents-of m))] 59 | (gen-tg/->set-parents! p (map member2person ps))) 60 | (is (= p (or (resolve-in :member2male m) 61 | (resolve-in :member2female m))))) 62 | (member2male 63 | :from [m 'Member] 64 | ;; Just for testing purposes, use the full name as identity rather than the 65 | ;; Member element itself. 66 | :id [id (str (emf/eget m :firstName) " " 67 | (emf/eget (family m) :lastName))] 68 | ;;:dup-id-eval true 69 | :when (male? m) 70 | ;; This nonsense is just here to test that there may be multiple 71 | ;; :let/:when/:when-let clauses. 72 | :let [x m] 73 | :when (male? x) 74 | :let [y x] 75 | :when [y] 76 | :when-let [z y 77 | foo z] 78 | :to [p 'Male :in out {:wife (when-let [w (wife z)] (member2female w)) 79 | :fullName id}] 80 | (is (= p (resolve-in :member2male m)))) 81 | (member2female 82 | :from [m 'Member] 83 | :when (not (male? m)) 84 | :to [p 'Female {:fullName (str (emf/eget m :firstName) " " 85 | (emf/eget (family m) :lastName))}] 86 | (is (= p (resolve-in :member2female m))))) 87 | 88 | (deftest test-families2genealogy 89 | (let [in (emf/load-resource "test/input/example.families") 90 | out-schema (load-schema "test/input/genealogy-schema.tg") 91 | ng (new-graph out-schema) 92 | _ (print "families2genealogy (EMF -> TG): ") 93 | trace (time (families2genealogy in ng))] 94 | #_(viz/print-model ng :gtk) 95 | (is (== 13 (vcount ng 'Person))) 96 | (is (== 7 (vcount ng 'Female))) 97 | (is (== 6 (vcount ng 'Male))) 98 | (is (== 3 (ecount ng 'HasSpouse))) 99 | (is (== 18 (ecount ng 'HasChild))) 100 | (is (== 3 (count (vseq ng 'Address)))) 101 | #_(clojure.pprint/pprint trace))) 102 | 103 | (deftransformation families2genealogy-ext 104 | "Like families2genealogy, but prepends Mr./Mrs. to first names." 105 | [^:in in ^:out out] 106 | :extends families2genealogy 107 | (first-name [m] 108 | (str (if (male? m) "Mr. " "Mrs. ") 109 | (emf/eget m :firstName)))) 110 | 111 | (deftest test-families2genealogy-ext 112 | (let [in (emf/load-resource "test/input/example.families") 113 | out-schema (load-schema "test/input/genealogy-schema.tg") 114 | ng (new-graph out-schema) 115 | _ (print "families2genealogy-ext (EMF -> TG): ") 116 | trace (time (families2genealogy-ext in ng))] 117 | #_(viz/print-model ng :gtk) 118 | (is (== 13 (vcount ng 'Person))) 119 | (is (== 7 (vcount ng 'Female))) 120 | (is (== 6 (vcount ng 'Male))) 121 | (is (== 3 (ecount ng 'HasSpouse))) 122 | (is (== 18 (ecount ng 'HasChild))) 123 | (is (== 3 (count (vseq ng 'Address)))) 124 | #_(clojure.pprint/pprint trace))) 125 | 126 | (deftransformation families2genealogy-explicit-main 127 | "Transforms a family model to a genealogy model." 128 | [^:in in ^:out out] 129 | (first-name [m] 130 | (emf/eget m :firstName)) 131 | (make-address 132 | :from [street town] 133 | :to [adr 'Address {:street street, :town town}]) 134 | (member2person 135 | :from [m] 136 | :disjuncts [member2male member2female :as p] 137 | (set-value! p :fullName 138 | (str (first-name m) " " 139 | (emf/eget (family m) :lastName))) 140 | (set-value! p :ageGroup (enum-constant p (if (< (emf/eget m :age) 18) 141 | 'AgeGroup.CHILD 142 | 'AgeGroup.ADULT))) 143 | (g/set-adj! p :address (make-address (emf/eget (family m) :street) 144 | (emf/eget (family m) :town))) 145 | (when-let [ps (seq (parents-of m))] 146 | (g/set-adjs! p :parents (map member2person ps)))) 147 | (member2male 148 | :from [m 'Member] 149 | :when (male? m) 150 | :let [w (wife m)] 151 | :to [p 'Male :in out] 152 | (when w 153 | (g/set-adj! p :wife (member2female w)))) 154 | (member2female 155 | :from [m 'Member] 156 | :when (not (male? m)) 157 | :to [p 'Female]) 158 | ;; Try a main function instead of automatic application of ^:top rules. 159 | (main [] 160 | (doseq [m (emf/eallcontents in 'Member)] 161 | (member2person m)))) 162 | 163 | (deftest test-families2genealogy-explicit-main 164 | (let [in (emf/load-resource "test/input/example.families") 165 | out-schema (load-schema "test/input/genealogy-schema.tg") 166 | ng (new-graph out-schema) 167 | _ (print "families2genealogy-explicit-main (EMF -> TG): ") 168 | trace (time (families2genealogy-explicit-main in ng))] 169 | #_(viz/print-model ng :gtk) 170 | (is (== 13 (vcount ng 'Person))) 171 | (is (== 7 (vcount ng 'Female))) 172 | (is (== 6 (vcount ng 'Male))) 173 | (is (== 3 (ecount ng 'HasSpouse))) 174 | (is (== 18 (ecount ng 'HasChild))) 175 | (is (== 3 (count (vseq ng 'Address)))) 176 | #_(clojure.pprint/pprint trace))) 177 | 178 | (deftransformation families2genealogy-generic 179 | "Transforms a family model to a genealogy model." 180 | [^:in in ^:out out] 181 | (^:top member2person 182 | :from [m] 183 | :disjuncts [member2male member2female :as p] 184 | (g/set-aval! p :fullName 185 | (str (g/aval m :firstName) " " 186 | (g/aval (family m) :lastName))) 187 | (g/set-adj! p :address (family2address (family m))) 188 | (g/set-adjs! p :parents (map member2person (parents-of m)))) 189 | (member2male 190 | :from [m 'Member] 191 | :when (male? m) 192 | :let [w (wife m)] 193 | :to [p 'Male {:wife (member2female (wife m))}]) 194 | (member2female 195 | :from [m 'Member] 196 | :when (not (male? m)) 197 | :to [p 'Female]) 198 | (family2address 199 | :from [f 'Family] 200 | :id [id [(g/aval f :street) (g/aval f :town)]] 201 | :to [adr 'Address {:street (first id), :town (second id)}])) 202 | 203 | 204 | (deftest test-families2genealogy-generic 205 | (let [in (emf/load-resource "test/input/example.families") 206 | out-schema (load-schema "test/input/genealogy-schema.tg") 207 | ng (new-graph out-schema) 208 | _ (print "families2genealogy-generic (EMF -> TG): ") 209 | trace (time (families2genealogy-generic in ng))] 210 | #_(viz/print-model ng :gtk) 211 | (is (== 13 (vcount ng 'Person))) 212 | (is (== 7 (vcount ng 'Female))) 213 | (is (== 6 (vcount ng 'Male))) 214 | (is (== 3 (ecount ng 'HasSpouse))) 215 | (is (== 18 (ecount ng 'HasChild))) 216 | (is (== 13 (ecount ng 'LivesAt))) 217 | (is (== 3 (vcount ng 'Address))) 218 | #_(clojure.pprint/pprint trace))) 219 | 220 | 221 | (deftest test-valid-to-bindings 222 | (is (var? (eval '(funnyqt.model2model/deftransformation 223 | complex-to-bindings [^:in in ^:out out1 ^:out out2] 224 | (^:top rule1 225 | :from [x 'X] 226 | :to [a 'A 227 | b 'B :in out2 228 | c 'C {:name "Test"} 229 | d 'D :in out1 {:name "Test2"} 230 | e 'E 231 | f 'F {:name "Test3"} 232 | g 'G {:name "Test4"} :in out2 233 | h 'H 234 | i 'I 235 | j 'J :in out2 {:foo "Bar"} 236 | k (symbol "SomeType") 237 | l (symbol "SomeType") {:a 1 :b 2} :in out1 238 | m 'A :in out2 239 | n 'B {:a 1 :b 2} 240 | o (symbol "C") 241 | p (symbol "C") 242 | q (symbol "C") {:a 1 :b 2}])))))) 243 | 244 | 245 | (deftransformation copy-transformation-1 [^:in old ^:out new] 246 | (^:top element2element 247 | :from [oel] 248 | :let [cls (g/mm-class oel)] 249 | :to [nel cls] 250 | (doseq [attr (g/mm-all-attributes cls)] 251 | (g/set-aval! nel attr (g/aval oel attr))) 252 | (doseq [ref (g/mm-all-references cls)] 253 | (if (g/mm-multi-valued-property? cls ref) 254 | (when-let [oadjs (seq (g/adjs oel ref))] 255 | (g/set-adjs! nel ref (map element2element oadjs))) 256 | (when-let [oadj (g/adj oel ref)] 257 | (g/set-adj! nel ref (element2element oadj))))))) 258 | 259 | (deftest test-copy-transformation-1 260 | (let [in (emf/load-resource "test/input/example.families") 261 | out (emf/new-resource)] 262 | (copy-transformation-1 in out) 263 | (is (g/equal-models? in out)))) 264 | -------------------------------------------------------------------------------- /test/funnyqt/polyfns_test.clj: -------------------------------------------------------------------------------- 1 | (ns funnyqt.polyfns-test 2 | (:require [clojure.test :refer :all] 3 | [funnyqt 4 | [generic :as p] 5 | [polyfns :refer :all] 6 | [tg :as tg] 7 | [tg-test :refer :all] 8 | [utils :as u]])) 9 | 10 | ;;* Tests 11 | 12 | ;;** Tests with the route-graph 13 | 14 | (declare-polyfn aec-name-no-default [elem]) 15 | 16 | (declare-polyfn aec-name-no-default-no-dispatch-table 17 | {:no-dispatch-table true} 18 | [elem]) 19 | 20 | (declare-polyfn aec-name-with-default [elem] 21 | "--undefined--") 22 | 23 | (defpolyfn aec-name-no-default junctions.Junction [elem] 24 | "Junction") 25 | (defpolyfn aec-name-no-default-no-dispatch-table junctions.Junction [elem] 26 | "Junction") 27 | (defpolyfn aec-name-with-default junctions.Junction [elem] 28 | "Junction") 29 | 30 | (defpolyfn aec-name-no-default localities.Locality [elem] 31 | "Locality") 32 | (defpolyfn aec-name-no-default-no-dispatch-table localities.Locality [elem] 33 | "Locality") 34 | (defpolyfn aec-name-with-default localities.Locality [elem] 35 | "Locality") 36 | 37 | (defpolyfn aec-name-no-default localities.City [elem] 38 | "City") 39 | (defpolyfn aec-name-no-default-no-dispatch-table localities.City [elem] 40 | "City") 41 | (defpolyfn aec-name-with-default localities.City [elem] 42 | "City") 43 | 44 | (defpolyfn aec-name-no-default connections.Connection [elem] 45 | "Connection") 46 | (defpolyfn aec-name-no-default-no-dispatch-table connections.Connection [elem] 47 | "Connection") 48 | (defpolyfn aec-name-with-default connections.Connection [elem] 49 | "Connection") 50 | 51 | (try 52 | (aec-name-no-default (tg/first-vertex rg)) 53 | (catch Exception e 54 | (if (re-matches #"Multiple aec-name-no-default polyfn impls for type junctions\.Airport\." (.getMessage e)) 55 | (println "Tie in polyfn impls successfully detected.") 56 | (u/errorf "Tie in polyfn impls for aec-name-no-default not detected!")))) 57 | 58 | (try 59 | (aec-name-no-default-no-dispatch-table (first (tg/vseq rg 'Airport))) 60 | (catch Exception e 61 | (if (re-matches #"Multiple aec-name-no-default-no-dispatch-table polyfn impls for type junctions\.Airport\." (.getMessage e)) 62 | (println "Tie in polyfn impls successfully detected.") 63 | (u/errorf "Tie in polyfn impls for aec-name-no-default-no-dispatch-table not detected!")))) 64 | 65 | (try 66 | (aec-name-with-default (tg/first-vertex rg)) 67 | (catch Exception e 68 | (if (re-matches #"Multiple aec-name-with-default polyfn impls for type junctions\.Airport\." (.getMessage e)) 69 | (println "Tie in polyfn impls successfully detected.") 70 | (u/errorf "Tie in polyfn impls for aec-name-with-default not detected!")))) 71 | 72 | (defpolyfn aec-name-no-default junctions.Airport [e] 73 | "Airport") 74 | (defpolyfn aec-name-no-default-no-dispatch-table junctions.Airport [e] 75 | "Airport") 76 | (defpolyfn aec-name-with-default junctions.Airport [e] 77 | "Airport") 78 | 79 | (defpolyfn aec-name-no-default (localities.ContainsCrossroad 80 | localities.ContainsLocality 81 | localities.HasCapital) 82 | [e] 83 | "NoConnEdge") 84 | (defpolyfn aec-name-no-default-no-dispatch-table 85 | (localities.ContainsCrossroad 86 | localities.ContainsLocality 87 | localities.HasCapital) 88 | [e] 89 | "NoConnEdge") 90 | (defpolyfn aec-name-with-default (localities.ContainsCrossroad 91 | localities.ContainsLocality 92 | localities.HasCapital) 93 | [e] 94 | "NoConnEdge") 95 | 96 | (deftest test-polyfns-tg 97 | (doseq [x (tg/vseq rg '[:and Junction !Airport])] 98 | (is (= "Junction" (aec-name-no-default x))) 99 | (is (= "Junction" (aec-name-no-default-no-dispatch-table x))) 100 | (is (= "Junction" (aec-name-with-default x)))) 101 | 102 | (doseq [x (tg/vseq rg 'Airport)] 103 | (is (= "Airport" (aec-name-no-default x))) 104 | (is (= "Airport" (aec-name-no-default-no-dispatch-table x))) 105 | (is (= "Airport" (aec-name-with-default x)))) 106 | 107 | (doseq [x (tg/vseq rg '[:and Locality !City !Airport])] 108 | (is (= "Locality" (aec-name-no-default x))) 109 | (is (= "Locality" (aec-name-no-default-no-dispatch-table x))) 110 | (is (= "Locality" (aec-name-with-default x)))) 111 | 112 | (doseq [x (tg/vseq rg 'City)] 113 | (is (= "City" (aec-name-no-default x))) 114 | (is (= "City" (aec-name-no-default-no-dispatch-table x))) 115 | (is (= "City" (aec-name-with-default x)))) 116 | 117 | (doseq [x (tg/eseq rg 'Connection)] 118 | (is (= "Connection" (aec-name-no-default x))) 119 | (is (= "Connection" (aec-name-no-default-no-dispatch-table x))) 120 | (is (= "Connection" (aec-name-with-default x)))) 121 | 122 | (doseq [x (tg/vseq rg 'County)] 123 | (is (thrown-with-msg? Exception 124 | #"No aec-name-no-default polyfn implementation defined" 125 | (aec-name-no-default x))) 126 | (is (thrown-with-msg? Exception 127 | #"No aec-name-no-default-no-dispatch-table polyfn implementation defined" 128 | (aec-name-no-default-no-dispatch-table x))) 129 | (is (= "--undefined--" (aec-name-with-default x)))) 130 | 131 | (doseq [conn (tg/eseq rg '!Connection)] 132 | (is (= "NoConnEdge" (aec-name-no-default conn))) 133 | (is (= "NoConnEdge" (aec-name-no-default-no-dispatch-table conn))) 134 | (is (= "NoConnEdge" (aec-name-with-default conn))))) 135 | 136 | ;;** Tests with the PolyfnTestSchema 137 | 138 | (declare-polyfn ^:no-dispatch-table foo [el]) 139 | (defpolyfn foo A [el] :a) 140 | 141 | (declare-polyfn ^:no-dispatch-table bar [el] :default) 142 | (defpolyfn bar A [el] :a) 143 | (defpolyfn bar B [el] :b) 144 | 145 | (deftest test-with-polyfntestgraph 146 | (let [g (tg/new-graph (tg/load-schema "test/input/polyfntestschema.tg")) 147 | a (tg/create-vertex! g 'A) 148 | b (tg/create-vertex! g 'B) 149 | c (tg/create-vertex! g 'C) 150 | d (tg/create-vertex! g 'D) 151 | e (tg/create-vertex! g 'E) 152 | f (tg/create-vertex! g 'F)] 153 | ;; foo 154 | (is (= :a (foo a))) 155 | (is (= :a (foo b))) 156 | (is (= :a (foo c))) 157 | (is (= :a (foo d))) 158 | (is (thrown-with-msg? Exception #"No foo polyfn implementation defined for type E" 159 | (foo e))) 160 | (is (= :a (foo f))) 161 | 162 | ;; bar 163 | (is (= :a (bar a))) 164 | (is (= :b (bar b))) 165 | (is (= :a (bar c))) 166 | (is (thrown-with-msg? Exception #"Multiple bar polyfn impls for type D." 167 | (bar d))) 168 | (is (= :default (bar e))) 169 | (is (thrown-with-msg? Exception #"Multiple bar polyfn impls for type F." 170 | (bar f))))) 171 | -------------------------------------------------------------------------------- /test/funnyqt/query/emf_test.clj: -------------------------------------------------------------------------------- 1 | (ns funnyqt.query.emf-test 2 | (:refer-clojure :exclude [parents]) 3 | (:require [clojure.test :refer :all] 4 | [funnyqt 5 | [emf :refer :all] 6 | [emf-test :refer [family-model]] 7 | [query :as q] 8 | [utils :as u]] 9 | [funnyqt.query.emf :refer :all])) 10 | 11 | (deftest test-basic-rpes 12 | (let [fm (q/the (econtents family-model))] 13 | (are [x y z n] (let [ox (u/oset x)] 14 | (and (= ox y z) (== n (count ox)))) 15 | (erefs fm) (--> fm) (q/--> fm) 16 16 | ;;;; 17 | (ecrossrefs fm) (---> fm) (q/---> fm) 0 18 | ;;;; 19 | (erefs fm :members) (q/p-seq fm :members) (q/--> fm :members) 13 20 | ;;;; 21 | (erefs fm :families) (q/p-seq fm :families) (q/<>-- fm :families) 3 22 | ;;;; 23 | (erefs fm [:members :families]) 24 | (q/p-alt fm :members :families) 25 | (q/p-alt fm [--> :members] [q/--> :families]) 26 | 16 27 | ;;;; 28 | (eallcontents family-model) 29 | (q/p-* fm -->) 30 | (q/p-* fm -->) 31 | 17))) 32 | 33 | (defn get-member 34 | [first-name] 35 | (q/the (filter #(= (eget % :firstName) first-name) 36 | (eallcontents family-model 'Member)))) 37 | 38 | (defn get-family 39 | [street] 40 | (q/the (filter #(= (eget % :street) street) 41 | (eallcontents family-model 'Family)))) 42 | 43 | (deftest test--<> 44 | (let [fm (q/the (econtents family-model)) 45 | diana (get-member "Diana")] 46 | (is (= #{fm} (--<> diana))) 47 | (is (= #{} (--<> fm))))) 48 | 49 | (deftest test<--- 50 | (let [fm (q/the (econtents family-model)) 51 | diana (get-member "Diana") 52 | dennis (get-member "Dennis")] 53 | (is (= #{(get-family "Smithway 17")} (<--- diana))) 54 | (is (= #{(get-family "Smithway 17") 55 | (get-family "Smith Avenue 4")} 56 | (<--- dennis))) 57 | ;; Using the opposite ref 58 | (is (= #{(get-family "Smithway 17")} 59 | (---> dennis :familyFather) 60 | (<--- dennis :father))) 61 | ;; Using search 62 | (is (= #{(get-family "Smithway 17")} 63 | (---> dennis :familyFather) 64 | (<--- dennis :father (econtents fm)))) 65 | (is (= #{(get-family "Smithway 17")} 66 | (---> dennis :familyFather) 67 | (<--- dennis :father family-model))) 68 | (is (= #{(get-family "Smithway 17")} 69 | (---> dennis :familyFather) 70 | (<--- dennis :father (eallcontents family-model 'Family)))) 71 | (is (= #{(get-family "Smithway 17") 72 | (get-family "Smith Avenue 4")} 73 | (---> dennis [:familyFather :familySon]) 74 | (<--- dennis [:father :sons]))))) 75 | 76 | (deftest test<-- 77 | (let [fm (q/the (econtents family-model)) 78 | diana (get-member "Diana") 79 | dennis (get-member "Dennis")] 80 | (is (= #{fm (get-family "Smithway 17")} (<-- diana))) 81 | (is (= #{fm} (<-- diana :members))) 82 | (is (= #{fm 83 | (get-family "Smithway 17") 84 | (get-family "Smith Avenue 4")} 85 | (<-- dennis))) 86 | ;; Using the opposite ref 87 | (is (= #{(get-family "Smithway 17")} 88 | (--> dennis :familyFather) 89 | (<-- dennis :father))) 90 | ;; Using search 91 | (is (= #{(get-family "Smithway 17")} 92 | (--> dennis :familyFather) 93 | (<-- dennis :father (econtents fm)))) 94 | (is (= #{(get-family "Smithway 17") 95 | (get-family "Smith Avenue 4")} 96 | (--> dennis [:familyFather :familySon]) 97 | (<-- dennis [:father :sons]))) 98 | (is (= #{fm 99 | (get-family "Smithway 17") 100 | (get-family "Smith Avenue 4")} 101 | (--> dennis [:model :familyFather :familySon]) 102 | (<-- dennis [:members :father :sons]))))) 103 | 104 | (defn ^:private parents 105 | [m] 106 | (q/p-seq m 107 | [q/p-alt :familySon :familyDaughter] 108 | [q/p-alt :father :mother])) 109 | 110 | (defn ^:private aunts-or-uncles 111 | [m r] 112 | (let [ps (parents m)] 113 | (q/p-seq ps 114 | [q/p-alt :familySon :familyDaughter] 115 | r 116 | [q/p-restr nil #(not (q/member? % ps))]))) 117 | 118 | (defn ^:private aunts-or-uncles2 119 | [m r] 120 | (let [ps (parents m)] 121 | (q/p-seq ps 122 | #(q/p-alt % :familySon :familyDaughter) 123 | r 124 | (fn [n] (q/p-restr n nil #(not (q/member? % ps))))))) 125 | 126 | (defn ^:private aunts-or-uncles3 127 | [m r] 128 | (let [ps (parents m)] 129 | (q/p-seq ps 130 | [q/p-alt :familySon :familyDaughter] 131 | r 132 | [q/p-restr nil #(not (q/member? % ps))]))) 133 | 134 | (defn ^:private aunts 135 | [m] 136 | (aunts-or-uncles m :daughters)) 137 | 138 | (defn ^:private uncles 139 | [m] 140 | (aunts-or-uncles m :sons)) 141 | 142 | (deftest test-relationships 143 | (let [diana (get-member "Diana") 144 | ps (parents diana) 145 | us (uncles diana) 146 | us2 (aunts-or-uncles2 diana :sons) 147 | us3 (aunts-or-uncles3 diana :sons) 148 | as (aunts diana) 149 | as2 (aunts-or-uncles2 diana :daughters) 150 | as3 (aunts-or-uncles3 diana :daughters)] 151 | (is (== 2 (count ps))) 152 | (is (= #{"Debby" "Dennis"} 153 | (into #{} (map #(eget % :firstName) ps)))) 154 | (is (== 2 (count us) (count us2) (count us3))) 155 | (is (= #{"Stu" "Sven"} 156 | (into #{} (map #(eget % :firstName) us)) 157 | (into #{} (map #(eget % :firstName) us2)) 158 | (into #{} (map #(eget % :firstName) us3)))) 159 | (is (== 3 (count as) (count as2) (count as3))) 160 | (is (= #{"Stella" "Carol" "Conzuela"} 161 | (into #{} (map #(eget % :firstName) as)) 162 | (into #{} (map #(eget % :firstName) as2)) 163 | (into #{} (map #(eget % :firstName) as3)))))) 164 | -------------------------------------------------------------------------------- /test/funnyqt/query/tg_test.clj: -------------------------------------------------------------------------------- 1 | (ns funnyqt.query.tg-test 2 | (:use funnyqt.tg) 3 | (:use funnyqt.query.tg) 4 | (:require [funnyqt.generic :as g] 5 | [funnyqt.query :as q] 6 | [funnyqt.utils :as u] 7 | [funnyqt.tg-test :refer [rg jg]]) 8 | (:use clojure.test)) 9 | 10 | (deftest test---> 11 | (mapv #(is (= %1 %2 %3)) 12 | ;; TG --> 13 | (let [m (map id (--> (vertex rg 12)))] 14 | ;; There are 9 reachable unique vertices 15 | (is (= 9 (count m))) 16 | m) 17 | ;; Generic --> 18 | (let [m (map id (q/--> (vertex rg 12)))] 19 | ;; There are 9 reachable unique vertices 20 | (is (= 9 (count m))) 21 | m) 22 | ;; and that's the order (by ids) 23 | [7 6 3 4 1 2 10 11 5])) 24 | 25 | (deftest test-<-- 26 | (is (= 0 27 | (count (<-- (vertex rg 12))) 28 | (count (q/<-- (vertex rg 12)))))) 29 | 30 | (deftest test-<-> 31 | (mapv #(is (= %1 %2 %3)) 32 | (let [m (map id (<-> (vertex rg 12)))] 33 | ;; There are 9 reachable unique vertices 34 | (is (= 9 (count m))) 35 | m) 36 | (let [m (map id (q/<-> (vertex rg 12)))] 37 | ;; There are 9 reachable unique vertices 38 | (is (= 9 (count m))) 39 | m) 40 | ;; and that's the order (by ids) 41 | [7 6 3 4 1 2 10 11 5])) 42 | 43 | (deftest test-reachable-vertices 44 | (is (= 2 45 | (count (q/p-seq (vertex rg 1) --<> [q/p-* [--> 'localities.HasCapital]])) 46 | (count (q/p-seq (vertex rg 1) --<> [q/p-* [q/--> 'localities.HasCapital]])))) 47 | (is (= 4272 48 | (count (q/p-* (vertex jg 12) -->)) 49 | (count (q/p-* (vertex jg 12) q/-->)))) 50 | (is (= 4272 51 | (count (q/p-+ (vertex jg 12) -->)) 52 | (count (q/p-+ (vertex jg 12) q/-->)))) 53 | (is (= 6117 54 | (count (q/p-* (vertex jg 12) <->)) 55 | (count (q/p-* (vertex jg 12) q/<->)))) 56 | (is (= 6117 57 | (count (q/p-+ (vertex jg 12) <->)) 58 | (count (q/p-+ (vertex jg 12) q/<->)))) 59 | (is (= 19 60 | (count (q/p-+ (vertex jg 12) <>--)) 61 | (count (q/p-+ (vertex jg 12) q/<>--)))) 62 | (is (= 20 63 | (count (q/p-* (vertex jg 12) <>--)) 64 | (count (q/p-* (vertex jg 12) q/<>--)))) 65 | (is (= 22 66 | (count (q/p-seq (vertex jg 12) [q/p-* <>--] -->)) 67 | (count (q/p-seq (vertex jg 12) [q/p-* q/<>--] q/-->)))) 68 | (is (= 4272 69 | (count (q/p-seq (vertex jg 12) [q/p-* <>--] [q/p-+ -->])) 70 | (count (q/p-seq (vertex jg 12) [q/p-* q/<>--] [q/p-+ q/-->])))) 71 | (let [tg (q/p-+ (vertex jg 12) [q/p-seq <>-- -->]) 72 | ge (q/p-+ (vertex jg 12) [q/p-seq q/<>-- q/-->])] 73 | (is (= 2337 (count tg) (count ge))) 74 | (is (= tg ge))) 75 | (is (= 6 76 | (count (q/p-seq (vertex jg 12) 77 | [q/p-+ [q/p-seq <>-- -->]] 78 | [q/p-restr 'annotations.Annotable])) 79 | (count (q/p-seq (vertex jg 12) 80 | [q/p-+ [q/p-seq q/<>-- q/-->]] 81 | [q/p-restr 'annotations.Annotable])))) 82 | (let [tg (q/p-seq (vertex jg 12) 83 | [q/p-opt --<>] 84 | [q/p-+ [q/p-seq <>-- -->]] 85 | [q/p-opt <--]) 86 | ge (q/p-seq (vertex jg 12) 87 | [q/p-opt q/--<>] 88 | [q/p-+ [q/p-seq q/<>-- q/-->]] 89 | [q/p-opt q/<--])] 90 | (is (= 3280 (count tg) (count ge))) 91 | (is (= tg ge))) 92 | (is (= 6 93 | (count (q/p-alt (vertex jg 12) <>-- --<>)) 94 | (count (q/p-alt (vertex jg 12) q/<>-- q/--<>))))) 95 | 96 | (deftest test-p-exp 97 | (is (= (q/p-seq (vertex jg 12) --> --> -->) 98 | (q/p-seq (vertex jg 12) q/--> q/--> q/-->) 99 | (q/p-exp (vertex jg 12) 3 -->) 100 | (q/p-exp (vertex jg 12) 3 q/-->))) 101 | (is (= (--> (vertex jg 12)) 102 | (q/--> (vertex jg 12)) 103 | (q/p-exp (vertex jg 12) 1 -->) 104 | (q/p-exp (vertex jg 12) 1 q/-->))) 105 | (is (= (u/oset (vertex jg 12)) 106 | (q/p-exp (vertex jg 12) 0 -->))) 107 | (is (= (q/p-seq (vertex jg 12) 108 | --> --> --> 109 | [q/p-opt -->] [q/p-opt -->] [q/p-opt -->]) 110 | (q/p-seq (vertex jg 12) 111 | q/--> q/--> q/--> 112 | [q/p-opt q/-->] [q/p-opt q/-->] [q/p-opt q/-->]) 113 | (q/p-exp (vertex jg 12) 3 6 -->))) 114 | (is (= (q/p-seq (vertex jg 12) [q/p-opt -->] [q/p-opt -->] [q/p-opt -->]) 115 | (q/p-exp (vertex jg 12) 0 3 -->)))) 116 | 117 | (deftest test-p-+* 118 | (is (= (q/p-+ (vertex jg 1) <->) 119 | (q/p-seq (vertex jg 1) <-> [q/p-* <->]))) 120 | (is (contains? (q/p-* (vertex jg 1) <>--) 121 | (vertex jg 1))) 122 | (is (not (contains? (q/p-+ (vertex jg 1) <>--) 123 | (vertex jg 1))))) 124 | 125 | (deftest test-p-+*2 126 | (doseq [p [[q/p-seq <-> <->] 127 | <>-- 128 | <>-- 129 | <->-- 130 | [q/p-alt [q/p-seq --> -->] 131 | [q/p-seq <-- <--]]]] 132 | (doseq [vid [1 20 117 3038]] 133 | (is (= (q/p-+ (vertex jg vid) p) 134 | (q/p-seq (vertex jg vid) p [q/p-* p]))) 135 | (is (= (q/p-* (vertex jg vid) p) 136 | (q/p-opt (vertex jg vid) [q/p-+ p])))))) 137 | 138 | (deftest test-derived-from-state 139 | (let [start (q/the (filter #(= (value %1 :name) "State") 140 | (vseq jg 'classifiers.Class)))] 141 | (let [tg (q/p-seq start 142 | [q/p-+ 143 | [q/p-seq 144 | [<-- 'types.ClassifierReferenceLinksToTarget] 145 | [--<> 'types.NamespaceClassifierReferenceContainsClassifierReferences] 146 | [--<> 'classifiers.ClassContainsExtends]]] 147 | [q/p-restr 'classifiers.Class 148 | (fn [v] 149 | (empty? (filter 150 | #(g/has-type? %1 'modifiers.Abstract) 151 | (g/adjs v :annotationsAndModifiers))))]) 152 | ge (q/p-seq start 153 | [q/p-+ 154 | [q/p-seq 155 | [q/<-- 'types.ClassifierReferenceLinksToTarget] 156 | [q/--<> 'types.NamespaceClassifierReferenceContainsClassifierReferences] 157 | [q/--<> 'classifiers.ClassContainsExtends]]] 158 | [q/p-restr 'classifiers.Class 159 | (fn [v] 160 | (empty? (filter 161 | #(g/has-type? %1 'modifiers.Abstract) 162 | (g/adjs v :annotationsAndModifiers))))])] 163 | (is (= 11 (count tg) (count ge))) 164 | (is (= tg ge))))) 165 | 166 | -------------------------------------------------------------------------------- /test/funnyqt/query_test.clj: -------------------------------------------------------------------------------- 1 | (ns funnyqt.query-test 2 | (:require [clojure.test :refer :all] 3 | [funnyqt.query :refer :all])) 4 | 5 | (deftest test-forall? 6 | (is (forall? even? [])) 7 | (is (forall? even? [2 4 10 100 666])) 8 | (is (forall? even? (take 50 (iterate (fn [x] (+ 2 x)) 0)))) 9 | (is (not (forall? even? [0 2 4 5 6])))) 10 | 11 | (deftest test-exists? 12 | (is (exists? even? [1 -7 3 5 6 -19 -4])) 13 | (is (not (exists? even? []))) 14 | ;; Test that we're not realizing lazy seqs too much 15 | (is (exists? even? (range)))) 16 | 17 | (deftest test-exist-n? 18 | (is (exist-n? 1 #(== 1 %) (range -100 100))) 19 | (is (not (exist-n? 1 even? [1 -7 3 5 6 -19 -4]))) 20 | (is (not (exist-n? 1 even? []))) 21 | (is (exist-n? 3 even? [1 2 3 4 5 6])) 22 | (is (not (exist-n? 3 even? [1 2 3 4 5 6 8]))) 23 | (is (not (exist-n? 3 even? [1 2 3 4 5]))) 24 | (is (exist-n? 1 even? [2])) 25 | (is (exist-n? 1 even? [3 2 1])) 26 | ;; Test that we're not realizing lazy seqs too much 27 | (is (not (exist-n? 100 even? (range))))) 28 | 29 | (deftest test-member? 30 | (is (member? 1 #{0 1 2})) 31 | (is (member? 1 [0 1 2])) 32 | (is (member? nil [nil 1 2])) 33 | (is (member? nil [0 nil 1 2])) 34 | (is (member? nil [0 nil])) 35 | (is (not (member? nil [0 1])))) 36 | 37 | (deftest test-the 38 | (is (== 1 (the [1]))) 39 | (is (== 1 (the #{1}))) 40 | (is (= [1 2] (the {1 2}))) 41 | (is (thrown-with-msg? Exception #"zero" (the []))) 42 | (is (thrown-with-msg? Exception #"more than" (the [1 2])))) 43 | 44 | (deftest test-pred-seq 45 | (is (= [[nil 1] [1 2] [2 3] [3 4]] 46 | (pred-seq [1 2 3 4])))) 47 | 48 | (deftest test-succ-seq 49 | (is (= [[1 2] [2 3] [3 4] [4 nil]] 50 | (succ-seq [1 2 3 4])))) 51 | 52 | (deftest test-xor 53 | (is (not (xor))) 54 | (is (xor true)) 55 | (is (not (xor nil))) 56 | (is (xor 1 nil)) 57 | (is (xor false 1)) 58 | (is (xor 1 nil false)) 59 | (is (xor nil 1 false)) 60 | (is (xor 1 2 3)) 61 | (is (not (xor false 2 3))) 62 | (is (xor 1 2 3 4 5 6 7)) 63 | (is (not (xor 1 2 3 4 5 6 nil)))) 64 | 65 | (deftest test-xor*-and-xor-fn 66 | (are [expected in] (= expected 67 | (apply xor* in) 68 | ((apply xor-fn (map constantly in)))) 69 | false [] 70 | true [true] 71 | false [false] 72 | true [true false] 73 | true [false true] 74 | false [true true] 75 | false [false false] 76 | true [true false false false false] 77 | true [false false false false true] 78 | false [true false false false false true] 79 | true [true false false false true true])) 80 | 81 | (deftest test-xor-fn 82 | (are [expected in] (= expected ((apply xor-fn in) 15)) 83 | ;; One pred matches 84 | true [#(== 13 %) #(== 15 %) #(== 17 %)] 85 | ;; No pred matches 86 | false [#(== 13 %) #(== 151 %) #(== 17 %)] 87 | ;; 2 preds match 88 | false [#(== 13 %) #(== 15 %) #(== 17 %) #(== 0 (mod % 5))] 89 | ;; 3 preds match 90 | true [#(< % 20) #(== 13 %) #(== 15 %) #(== 17 %) #(== 0 (mod % 5))] 91 | ;; No pred given 92 | false [])) 93 | 94 | (deftest test-logicals 95 | ;; AND 96 | (are [expected in] (= expected 97 | ((eval `(fn [] (and ~@in)))) 98 | (apply and* in) 99 | (reduce #(and %1 %2) true in)) 100 | 3 [1 2 3] 101 | true [] 102 | false [1 false] 103 | nil [nil 1 2 3 4] 104 | nil [1 2 nil 3]) 105 | ;; NAND 106 | (are [expected in] (= expected 107 | ((eval `(fn [] (nand ~@in)))) 108 | (apply nand* in) 109 | (not (reduce #(and %1 %2) true in))) 110 | false [1 2 3] 111 | false [] 112 | true [1 false] 113 | true [nil 1 2 3 4]) 114 | ;; OR 115 | (are [expected in] (= expected 116 | ((eval `(fn [] (or ~@in)))) 117 | (apply or* in) 118 | (reduce #(or %1 %2) nil in)) 119 | 1 [1 2 3] 120 | nil [] 121 | 1 [1 false] 122 | 1 [nil 1 2 3 4] 123 | false [nil nil false] 124 | nil [nil false nil] 125 | 1 [nil 1 false 2 nil]) 126 | ;; NOR 127 | (are [expected in] (= expected 128 | ((eval `(fn [] (nor ~@in)))) 129 | (apply nor* in) 130 | (not (reduce #(or %1 %2) nil in))) 131 | false [1 2 3] 132 | true [] 133 | false [1 false] 134 | false [nil 1 2 3 4] 135 | true [nil nil false]) 136 | ;; XOR 137 | (are [expected in] (= expected 138 | ((eval `(fn [] (xor ~@in)))) 139 | (apply xor* in) 140 | (reduce #(xor %1 %2) false in)) 141 | 3 [1 2 3] 142 | false [] 143 | 1 [1 false] 144 | false [nil 1 2 3 4] 145 | false [nil nil false])) 146 | 147 | (deftest test-and-fn-nand-fn 148 | (are [expected in] (= expected 149 | ((apply and-fn in) 15) 150 | (not ((apply nand-fn in) 15))) 151 | ;; One pred matches 152 | false [#(== 13 %) #(== 15 %) #(== 17 %)] 153 | ;; No pred matches 154 | false [#(== 13 %) #(== 151 %) #(== 17 %)] 155 | ;; Two but not all match 156 | false [#(== 13 %) #(== 15 %) #(== 17 %) #(== 0 (mod % 5))] 157 | ;; No pred given ==> all given match 158 | true [] 159 | ;; All match 160 | true [#(== 15 %)] 161 | true [#(== 15 %) #(== 0 (mod % 5)) #(== 0 (mod % 3))])) 162 | 163 | (deftest test-or-fn-nor-fn 164 | (are [expected in] (= expected 165 | ((apply or-fn in) 15) 166 | (not ((apply nor-fn in) 15))) 167 | ;; One pred matches 168 | true [#(== 13 %) #(== 15 %) #(== 17 %)] 169 | ;; No pred matches 170 | false [#(== 13 %) #(== 151 %) #(== 17 %)] 171 | ;; Two but not all match 172 | true [#(== 13 %) #(== 15 %) #(== 17 %) #(== 0 (mod % 5))] 173 | ;; No pred given 174 | false [] 175 | ;; All match 176 | true [#(== 15 %)] 177 | true [#(== 15 %) #(== 0 (mod % 5)) #(== 0 (mod % 3))])) 178 | 179 | (deftest test-seq-comparator 180 | (let [sorted [[-1 "zap" 19] 181 | [-1 "zap" 0] 182 | [0 "bar" 0] 183 | [0 "foo" 1] 184 | [0 "foo" 1] 185 | [0 "zap" 17] 186 | [1 "foo" 1] 187 | [1 "foo" 0] 188 | [2 "bar" 2] 189 | [2 "bar" 1]]] 190 | (dotimes [_ 30] 191 | (is (= sorted 192 | (sort 193 | ;; 1. ascending, 2. lexicographical, 3. descending 194 | (seq-comparator - compare #(- %2 %1)) 195 | (shuffle sorted))))))) 196 | -------------------------------------------------------------------------------- /test/funnyqt/relational/emf_test.clj: -------------------------------------------------------------------------------- 1 | (ns funnyqt.relational.emf-test 2 | (:refer-clojure :exclude [==]) 3 | (:require [clojure.core.logic :refer :all] 4 | [clojure.test :as t] 5 | [funnyqt 6 | [emf :as emf] 7 | [emf-test :refer :all] 8 | [generic :as g] 9 | [query :as q] 10 | [relational :refer :all]])) 11 | 12 | (generate-metamodel-relations "test/input/Families.ecore" 13 | test.relational.families.emf families +) 14 | 15 | (t/deftest test-elemento 16 | (t/is (= (emf/eallcontents family-model) 17 | (run* [q] 18 | (elemento family-model q))))) 19 | 20 | (t/deftest test-elemento-with-type 21 | (t/is (= (emf/eallcontents family-model 'Member) 22 | (run* [q] 23 | (elemento family-model q) 24 | (typeo family-model q 'Member)) 25 | (run* [q] 26 | (families/+Member family-model q)))) 27 | (t/is (= (emf/eallcontents family-model '!Member) 28 | (run* [q] 29 | (typeo family-model q '!Member) 30 | (elemento family-model q)) 31 | (run* [q] 32 | (families/+!Member family-model q))))) 33 | 34 | (t/deftest test-relationshipo-error 35 | (t/is (thrown-with-msg? Exception #".*Cannot use relationshipo.*" 36 | (doall 37 | (run* [q s t] 38 | (relationshipo family-model q s t)))))) 39 | 40 | (t/deftest test-avalo 41 | (t/is (= (map (fn [e] 42 | [e (emf/eget e :firstName)]) 43 | (emf/eallcontents family-model 'Member)) 44 | (run* [q] 45 | (with-fresh 46 | (avalo family-model ?elem :firstName ?val) 47 | (== q [?elem ?val]))) 48 | (run* [q] 49 | (with-fresh 50 | (families/+firstName family-model ?elem ?val) 51 | (== q [?elem ?val])))))) 52 | 53 | (t/deftest test-adjo 54 | (let [fam-carter (q/the #(= "Carter" (emf/eget % :lastName)) 55 | (emf/eallcontents family-model 'Family))] 56 | (t/is (= (g/adjs fam-carter :daughters) 57 | (run* [q] 58 | (adjo family-model fam-carter :daughters q)) 59 | (run* [q] 60 | (families/+->daughters family-model fam-carter q)))))) 61 | -------------------------------------------------------------------------------- /test/funnyqt/relational/tg_test.clj: -------------------------------------------------------------------------------- 1 | (ns funnyqt.relational.tg-test 2 | (:refer-clojure :exclude [==]) 3 | (:require [clojure.core.logic :refer [run* == conde conda all fresh membero nafc everyg succeed !=]] 4 | [clojure.core.logic.fd :as fd] 5 | [clojure.test :refer :all] 6 | [funnyqt 7 | [emf :as emf] 8 | [generic :as g] 9 | [relational :refer :all] 10 | [tg :as tg] 11 | [tg-test :refer :all] 12 | [model2model-test :as m2m-test]] 13 | [funnyqt.coevo.tg :as coevo])) 14 | 15 | (generate-metamodel-relations "test/input/greqltestgraph.tg" 16 | test.relational.routemap.tg routemap +) 17 | 18 | ;;* Basic tests 19 | 20 | (deftest test-elemento 21 | (is (= (tg/vseq rg) 22 | (run* [q] 23 | (elemento rg q))))) 24 | 25 | (deftest test-relationshipo 26 | (is (= (tg/eseq rg) 27 | (run* [q] 28 | (with-fresh 29 | (relationshipo rg q _ _))))) 30 | (is (= (map (fn [e] 31 | [e (g/qname e) (tg/alpha e) (tg/omega e)]) 32 | (tg/eseq rg)) 33 | (run* [q] 34 | (with-fresh 35 | (typeo rg ?e ?t) 36 | (relationshipo rg ?e ?a ?o) 37 | (== q [?e ?t ?a ?o])))))) 38 | 39 | (deftest test-elemento-and-relationshipo-with-type 40 | (is (= (tg/vseq rg 'Junction) 41 | (run* [q] 42 | (typeo rg q 'Junction) 43 | (elemento rg q)) 44 | (run* [q] 45 | (routemap/+Junction rg q)))) 46 | (is (= (tg/eseq rg 'Connection) 47 | (run* [q] 48 | (with-fresh 49 | (typeo rg q 'Connection) 50 | (relationshipo rg q _ _))) 51 | (run* [q] 52 | (with-fresh 53 | (routemap/+Connection rg q _ _)))))) 54 | 55 | (deftest test-avalo 56 | (is (= (map (fn [e] 57 | [e (tg/value e :name)]) 58 | (concat (tg/vseq rg '[NamedElement Plaza]) 59 | (tg/eseq rg 'Street))) 60 | (run* [q] 61 | (with-fresh 62 | (avalo rg ?elem :name ?val) 63 | (== q [?elem ?val]))) 64 | (run* [q] 65 | (with-fresh 66 | (routemap/+name rg ?elem ?val) 67 | (== q [?elem ?val])))))) 68 | 69 | (deftest test-adjo 70 | (is (= (g/adjs (tg/vertex rg 12) :localities) 71 | (run* [q] 72 | (adjo rg (tg/vertex rg 12) :localities q)) 73 | (run* [q] 74 | (routemap/+->localities rg (tg/vertex rg 12) q)))) 75 | (is (= (g/adjs (tg/vertex rg 12) :capital) 76 | (run* [q] 77 | (adjo rg (tg/vertex rg 12) :capital q)) 78 | (run* [q] 79 | (routemap/+->capital rg (tg/vertex rg 12) q))))) 80 | 81 | ;;* Tests with the Genealogy graph 82 | 83 | (generate-metamodel-relations "test/input/genealogy-schema.tg" 84 | test.relational.genealogy.tg-test gen) 85 | 86 | (def g (let [fm (emf/load-resource "test/input/example.families") 87 | g (tg/new-graph (tg/load-schema "test/input/genealogy-schema.tg"))] 88 | (m2m-test/families2genealogy fm g) 89 | (coevo/delete-attribute! g 'Person :ageGroup) 90 | g)) 91 | 92 | (deftest test-elemento-familygraph 93 | (is (= (g/elements g) 94 | (run* [q] 95 | (elemento g q))))) 96 | 97 | (defn parento 98 | ([m parent child] 99 | (gen/->children m parent child)) 100 | ([m parent-c child-c parent child] 101 | (all 102 | (parent-c m parent) 103 | (parento m parent child) 104 | (child-c m child)))) 105 | 106 | (defn fathero [m father child] 107 | (parento m gen/Male alwayso father child)) 108 | 109 | (defn mothero [m mother child] 110 | (parento m gen/Female alwayso mother child)) 111 | 112 | (defn sono [m parent son] 113 | (parento m alwayso gen/Male parent son)) 114 | 115 | (defn daughtero [m parent daughter] 116 | (parento m alwayso gen/Female parent daughter)) 117 | 118 | ;; All fathers with their daughters 119 | ;; (run* [p c] 120 | ;; (fathero g p c) 121 | ;; (daughtero g p c)) 122 | 123 | (run* [f d] 124 | (parento g gen/Male gen/Female f )) 125 | ;;=> ([# #] 126 | ;; [# #] 127 | ;; [# #] 128 | ;; [# #] 129 | ;; [# #]) 130 | 131 | (defn grandparento 132 | ([m grandparent grandchild] 133 | (with-fresh 134 | (parento m grandparent ?parent) 135 | (parento m ?parent grandchild))) 136 | ([m grandparent-c grandchild-c grandparent grandchild] 137 | (all 138 | (grandparent-c m grandparent) 139 | (grandparento m grandparent grandchild) 140 | (grandchild-c m grandchild)))) 141 | 142 | (defn grandfathero [m grandfather grandchild] 143 | (grandparento m gen/Male alwayso grandfather grandchild)) 144 | 145 | (defn grandmothero [m grandmother grandchild] 146 | (grandparento m gen/Female alwayso grandmother grandchild)) 147 | 148 | (defn grandsono [m grandparent grandson] 149 | (grandparento m alwayso gen/Male grandparent grandson)) 150 | 151 | (defn granddaughtero [m grandparent granddaughter] 152 | (grandparento m alwayso gen/Female grandparent granddaughter)) 153 | 154 | 155 | (defn siblingo [m s1 s2] 156 | (with-fresh 157 | (parento m ?parent s1) 158 | (parento m ?parent s2) 159 | (!= s1 s2))) 160 | 161 | (defn aunto [m aunt nephew] 162 | (with-fresh 163 | (parento m ?parent nephew) 164 | (siblingo m ?parent aunt) 165 | (gen/Female m aunt))) 166 | 167 | (distinct 168 | (run* [aunt nephew] 169 | (aunto g aunt nephew))) 170 | ;;=> ([# #] [# #] 171 | ;; [# #] [# #] 172 | ;; [# #] [# #]) 173 | 174 | ;; All grandmothers with their grandsons 175 | ;; (run* [gp gc] 176 | ;; (grandmothero g gp gc) 177 | ;; (grandsono g gp gc)) 178 | 179 | (run* [q] 180 | (fresh [a b] 181 | (== q #{a b}) ;; StackOverflowError 182 | ;;(== q [a b]) ;; works 183 | ;;(== q (list a b)) ;; works, too 184 | (conde [(== a 1)] [(== a 2)] [(== a 3)]) 185 | (conde [(== b 1)] [(== b 2)] [(== b 3)]))) 186 | 187 | (defn ancestoro [m a p] 188 | (conde 189 | [(parento m a p)] 190 | [(with-fresh 191 | (parento m a ?i) 192 | (ancestoro m ?i p))])) 193 | 194 | ;; (run* [a p] 195 | ;; (ancestoro g a p)) 196 | -------------------------------------------------------------------------------- /test/funnyqt/utils_test.clj: -------------------------------------------------------------------------------- 1 | (ns funnyqt.utils-test 2 | (:require [clojure.test :refer :all] 3 | [funnyqt.utils :refer :all])) 4 | 5 | (deftest test-qname? 6 | (is (qname? 'foo.bar.Baz)) 7 | (is (qname? 'foo.bar.Baz!)) 8 | (is (qname? 'Baz)) 9 | (is (qname? '!Baz)) 10 | (is (qname? 'B)) 11 | (is (qname? 'Baz2)) 12 | (is (qname? 'Baz2!)) 13 | (is (qname? 'foo.b_a_r1.Baz)) 14 | (is (not (qname? :foo.bar.Baz))) 15 | (is (not (qname? 'foo.bar.1Baz)))) 16 | 17 | (deftest test-prop-name? 18 | (is (prop-name? :foo)) 19 | (is (prop-name? :x)) 20 | (is (prop-name? :fooBar)) 21 | (is (prop-name? :foo_Bar)) 22 | (is (not (prop-name? :Baz))) 23 | (is (not (prop-name? 'foo)))) 24 | -------------------------------------------------------------------------------- /test/funnyqt/xmltg_test.clj: -------------------------------------------------------------------------------- 1 | (ns funnyqt.xmltg-test 2 | (:require [funnyqt 3 | [tg :refer :all] 4 | [xmltg :refer :all]]) 5 | (:use clojure.test)) 6 | 7 | (deftest test-example-with-dtd 8 | (let [g (xml2xml-graph "test/input/xmltg-example-with-dtd.xml")] 9 | (is (== 123 (vcount g))) 10 | (is (== 1 (vcount g 'RootElement))) 11 | (is (== 55 (vcount g 'Element))) 12 | (is (== 75 (vcount g 'Node))) 13 | (is (== 48 (vcount g 'Attribute))) 14 | (is (== 20 (vcount g 'CharContent))) 15 | (is (== 142 (ecount g))) 16 | (is (== 20 (ecount g 'References))) 17 | ;; Only the root element has no incoming HasContent edges 18 | (is (= (vseq g 'RootElement) 19 | (filter #(== 0 (degree % 'HasContent :in)) 20 | (vseq g 'Element)))) 21 | ;; Any attribute has exactly one incoming HasAttribute edge 22 | (is (empty? (filter #(not= 1 (degree % 'HasAttribute :in)) 23 | (vseq g 'Attribute)))))) 24 | 25 | (defn ^:private asserts-for-idrefs-example 26 | [g] 27 | (is (== 112 (vcount g))) 28 | (is (== 1 (vcount g 'RootElement))) 29 | (is (== 49 (vcount g 'Element))) 30 | (is (== 69 (vcount g 'Node))) 31 | (is (== 43 (vcount g 'Attribute))) 32 | (is (== 20 (vcount g 'CharContent))) 33 | (is (== 131 (ecount g))) 34 | (is (== 20 (ecount g 'References))) 35 | ;; Only the root element has no incoming HasContent edges 36 | (is (= (vseq g 'RootElement) 37 | (filter #(== 0 (degree % 'HasContent :in)) 38 | (vseq g 'Element)))) 39 | ;; Any attribute has exactly one incoming HasAttribute edge 40 | (is (empty? (filter #(not= 1 (degree % 'HasAttribute :in)) 41 | (vseq g 'Attribute)))) 42 | ;; One attribute with 6 outgoing refs 43 | (is (== 1 (count (filter #(== 6 (degree % 'References :out)) 44 | (vseq g 'Attribute)))))) 45 | 46 | (deftest test-example-with-dtd-and-IDREFS 47 | (let [g (xml2xml-graph "test/input/xmltg-example-with-dtd-and-IDREFS.xml")] 48 | (asserts-for-idrefs-example g))) 49 | 50 | (deftest test-example-without-dtd 51 | (let [g (xml2xml-graph "test/input/xmltg-example-without-dtd.xml" 52 | ;; This is a function that gets 3 parameters: an 53 | ;; elements expanded name, an attribute (declared) 54 | ;; name, and the attribute value. Given that, it 55 | ;; should return the attribute's correct type: ID, 56 | ;; IDREF, IDREFS, EMFFragmentPath, or nil/CDATA 57 | ;; otherwise. 58 | (fn [exp-name aname aval] 59 | (cond 60 | ;; In this simple example, the ID-typed attrs are named 61 | ;; ID, the IDREF-typed attributes are named IDREF, and 62 | ;; the IDREFS-typed attribute (of the element type 63 | ;; FAMILY) in named CHILDREN. Here, we can simply 64 | ;; ignore the element qualified name given to the 65 | ;; function as first parameter. 66 | (= aname "ID") "ID" 67 | (= aname "IDREF") "IDREF" 68 | (= aname "CHILDREN") "IDREFS")))] 69 | (asserts-for-idrefs-example g))) 70 | 71 | (deftest test-example-with-semantically-importants-text 72 | (let [g (xml2xml-graph "test/input/xml-example-with-semantically-important-text.xml" 73 | nil 74 | (fn [p c v] 75 | (condp = c 76 | "pid" "ID" 77 | "spouse" "IDREF" 78 | "children" "IDREFS" 79 | "parents" "IDREFS")))] 80 | #_(show-graph g) 81 | (is (= 18 (vcount g 'Element))) 82 | (is (= 12 (vcount g 'CharContent))) 83 | (is (= 14 (ecount g 'References))))) 84 | 85 | -------------------------------------------------------------------------------- /test/input/AddressBook.ecore: -------------------------------------------------------------------------------- 1 | 2 | 4 | 5 | 6 | 7 | 8 | 10 | 11 | 12 | 14 | 16 | 17 | 18 | 19 | 21 | 22 | 23 | 24 | 25 | 26 | 28 | 29 | 30 | 31 | 33 | 34 | 35 | -------------------------------------------------------------------------------- /test/input/Families.ecore: -------------------------------------------------------------------------------- 1 | 2 | 6 | 7 | 9 | 11 | 13 | 15 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 25 | 27 | 29 | 31 | 33 | 34 | 35 | 36 | 38 | 40 | 41 | 42 | -------------------------------------------------------------------------------- /test/input/Genealogy.ecore: -------------------------------------------------------------------------------- 1 | 2 | 6 | 7 | 9 | 11 | 13 | 14 | 15 | 17 | 18 | 19 | 21 | 22 | 23 | 25 | 26 | 27 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | 37 | 39 | 40 | 41 | 42 | -------------------------------------------------------------------------------- /test/input/MutualExclusion.ecore: -------------------------------------------------------------------------------- 1 | 2 | 4 | 5 | 7 | 9 | 11 | 13 | 15 | 17 | 19 | 21 | 22 | 23 | 24 | 26 | 28 | 30 | 32 | 34 | 35 | 36 | -------------------------------------------------------------------------------- /test/input/PMatchTestMetamodel.ecore: -------------------------------------------------------------------------------- 1 | 2 | 4 | 5 | 6 | 8 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | -------------------------------------------------------------------------------- /test/input/PMatchTestSchema.tg: -------------------------------------------------------------------------------- 1 | TGraph 2; 2 | Schema pmatchtest.PMatchTestSchema; 3 | 4 | GraphClass PMatchTestGraph; 5 | 6 | VertexClass A {i : Integer}; 7 | VertexClass B : A; 8 | VertexClass C : A; 9 | VertexClass D {j : Integer}; 10 | 11 | EdgeClass A2A from A (0,*) role s to A (0,*) role t; 12 | EdgeClass A2D from A (0,*) to D (0,*) role d; 13 | -------------------------------------------------------------------------------- /test/input/addressbook.tg: -------------------------------------------------------------------------------- 1 | TGraph 2; 2 | Schema test.addressbook.AddressBookSchema; 3 | GraphClass AddressBookGraph; 4 | 5 | abstract VertexClass NamedElement {name: String}; 6 | VertexClass AddressBook: NamedElement; 7 | VertexClass Category: NamedElement; 8 | abstract VertexClass Entry {id: Integer}; 9 | VertexClass Contact: Entry {firstName: String, lastName: String, email: String}; 10 | VertexClass Organization: Entry, NamedElement {homepage: String}; 11 | 12 | EdgeClass ContainsCategory from AddressBook (1,1) role addressBook to Category (0,*) role categories aggregation composite; 13 | abstract EdgeClass ContainsEntry from Category (1,1) role category to Entry (0,*) role entries aggregation composite; 14 | EdgeClass ContainsContact from Category (1,1) to Contact (0,*) role contacts aggregation composite; 15 | EdgeClass ContainsOrganization from Category (1,1) to Organization (0,*) role organizations aggregation composite; 16 | EdgeClass HasEmployee from Organization (0,*) role employers to Contact (0,*) role employees; 17 | -------------------------------------------------------------------------------- /test/input/binop-tree-schema.tg: -------------------------------------------------------------------------------- 1 | TGraph 2; 2 | Schema test.binoptree.BinaryTreeSchema; 3 | GraphClass BinaryTree; 4 | 5 | abstract VertexClass Expression; 6 | EdgeClass HasArg from BinaryOp (0,1) to Expression (2,2); 7 | VertexClass Const : Expression {value : Double}; 8 | abstract VertexClass BinaryOp : Expression; 9 | VertexClass Add : BinaryOp; 10 | VertexClass Sub : BinaryOp; 11 | VertexClass Mul : BinaryOp; 12 | VertexClass Div : BinaryOp; 13 | -------------------------------------------------------------------------------- /test/input/cd2db-simple/cd-schema.tg: -------------------------------------------------------------------------------- 1 | TGraph 2; 2 | Schema de.uni_koblenz.funnyqt.test.cd_schema.CDSchema; 3 | GraphClass CDGraph; 4 | 5 | EnumDomain AttributeTypes (BOOLEAN, INT, LONG, FLOAT, DOUBLE, STRING); 6 | VertexClass Class {name: String}; 7 | VertexClass Attribute {name: String, type: AttributeTypes}; 8 | VertexClass Association {name: String}; 9 | 10 | EdgeClass Extends from Class (0,*) role subclasses to Class (0,1) role superclass; 11 | EdgeClass ContainsAttribute from Class (1,1) role class to Attribute (0,*) role attrs aggregation composite; 12 | EdgeClass HasSource from Association (0,*) to Class (1,1) role src; 13 | EdgeClass HasTarget from Association (0,*) to Class (1,1) role trg; 14 | -------------------------------------------------------------------------------- /test/input/cd2db-simple/db-schema.tg: -------------------------------------------------------------------------------- 1 | TGraph 2; 2 | Schema de.uni_koblenz.funnyqt.test.db_schema.DBSchema; 3 | GraphClass DBGraph; 4 | 5 | EnumDomain ColumnTypes (BOOLEAN, INTEGER, REAL, DOUBLE, VARCHAR, TEXT); 6 | VertexClass Table {name: String}; 7 | VertexClass Column {name: String, primary: Boolean, type: ColumnTypes}; 8 | 9 | EdgeClass ContainsColumn from Table (1,1) role table to Column (0,*) role cols aggregation composite; 10 | EdgeClass IsForeignKey from Column (0,*) role fkeys to Column (1,1) role pkey; 11 | -------------------------------------------------------------------------------- /test/input/classhierarchy.tg: -------------------------------------------------------------------------------- 1 | TGraph 2; 2 | 3 | Schema classhierarchy.ClassHierarchySchema; 4 | GraphClass ClassHierarchyGraph; 5 | VertexClass Class {name : String}; 6 | EdgeClass HasSuperClass from Class (0,*) role subclasses to Class (0,*) role superclasses; 7 | -------------------------------------------------------------------------------- /test/input/clock.ecore: -------------------------------------------------------------------------------- 1 | 2 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | -------------------------------------------------------------------------------- /test/input/component-schema-v1.tg: -------------------------------------------------------------------------------- 1 | TGraph 2; 2 | 3 | Schema funnyqt.test.component_schema_v1.ComponentSchema; 4 | GraphClass ComponentGraph; 5 | 6 | VertexClass Component {name : String}; 7 | VertexClass Connector {name : String}; 8 | VertexClass Port {name : String}; 9 | 10 | EdgeClass HasSubcomponent from Component (0,1) to Component (0,*) role subcomponents aggregation composite; 11 | EdgeClass HasPort from Component (0,1) to Port (0,*) role ports aggregation composite; 12 | 13 | EdgeClass ComesFrom from Connector (0,*) role outgoing to Port (1,1) role from; 14 | EdgeClass GoesTo from Connector (0,*) role incoming to Port (1,1) role to; 15 | -------------------------------------------------------------------------------- /test/input/counter-schema.tg: -------------------------------------------------------------------------------- 1 | // JGraLab - The Java graph laboratory 2 | // Version : Efraasia 3 | // Revision: 3528:56c9875e9fe4 4 | 5 | TGraph 2; 6 | Schema de.uni_koblenz.jgralabtest.counterschema.CounterSchema; 7 | GraphClass CounterGraph; 8 | VertexClass Digit { val : Integer }; 9 | VertexClass Counter; 10 | EdgeClass HasNext from Digit (1,1) to Digit (1,1); 11 | EdgeClass HasPrimaryDigit from Counter (0,1) to Digit (1,1) role primary; 12 | EdgeClass HasSecondaryDigit from Counter (0,1) to Digit (1,1) role secondary; 13 | -------------------------------------------------------------------------------- /test/input/documents.tg: -------------------------------------------------------------------------------- 1 | TGraph 2; 2 | 3 | Schema documents.DocumentSchema; 4 | GraphClass DocumentGraph; 5 | VertexClass Document {name : String}; 6 | EdgeClass LinksDirectly from Document (0,*) role srcs to Document (0,*) role trgs; 7 | EdgeClass LinksTransitively from Document (0,*) role allsrcs to Document (0,*) role alltrgs; 8 | -------------------------------------------------------------------------------- /test/input/dup-roles-graph.tg: -------------------------------------------------------------------------------- 1 | // JGraLab - The Java graph laboratory 2 | // Version : 6.5.2 3 | // Codename: Falkarius 4 | 5 | TGraph 2; 6 | Schema de.uni_koblenz.duproles.DupRoleSchema; 7 | GraphClass DupRoleGraph; 8 | VertexClass A; 9 | VertexClass B; 10 | VertexClass C; 11 | EdgeClass A2B from A (0,*) role as to B (0,*) role bs; 12 | EdgeClass A2C from A (0,*) role as to C (0,*) role cs; 13 | EdgeClass C2B from C (0,*) role cs to B (0,*) role bs; 14 | Graph "Created: Wed Aug 29 12:18:03 CEST 2012" 6 DupRoleGraph (500 500 3 3); 15 | Package ; 16 | 1 A <1 2>; 17 | 2 B <-1 -3>; 18 | 3 C <-2 3>; 19 | 1 A2B; 20 | 2 A2C; 21 | 3 C2B; 22 | -------------------------------------------------------------------------------- /test/input/example.families: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | -------------------------------------------------------------------------------- /test/input/familygraph.tg: -------------------------------------------------------------------------------- 1 | // JGraLab - The Java graph laboratory 2 | // Version : Efraasia 3 | // Revision: 3528:56c9875e9fe4 4 | 5 | TGraph 2; 6 | Schema de.uni_koblenz.jgralabtest.gretl.schemas.families.FamilySchema; 7 | GraphClass FamilyGraph; 8 | VertexClass Family { lastName: String, street: String, town: String }; 9 | VertexClass Member { age: Integer, firstName: String }; 10 | EdgeClass HasDaughter from Family (0,1) role familyDaughter to Member (0,*) role daughters aggregation shared; 11 | EdgeClass HasFather from Family (0,1) role familyFather to Member (1,1) role father aggregation shared; 12 | EdgeClass HasMother from Family (0,1) role familyMother to Member (1,1) role mother aggregation shared; 13 | EdgeClass HasSon from Family (0,1) role familySon to Member (0,*) role sons aggregation shared; 14 | Graph "918348b4-5153b25a-5668c393-2767b494" 66 FamilyGraph (1000 1000 16 15); 15 | Package ; 16 | 1 Family <1 2 3 4 5 11> "Smith" "Smith Avenue 4" "Smithtown"; 17 | 2 Member <-1> 66 "Steve"; 18 | 3 Member <-2> 61 "Stephanie"; 19 | 4 Member <-3> 27 "Stu"; 20 | 5 Member <-4> 31 "Sven"; 21 | 6 Member <-5> 29 "Stella"; 22 | 7 Family <6 7 8 9 13> "Carter" "Carter Street 2" "Cartertown"; 23 | 8 Member <-6> 51 "Chris"; 24 | 9 Member <-7> 49 "Christy"; 25 | 10 Member <-8> 25 "Carol"; 26 | 11 Member <-9> 17 "Conzuela"; 27 | 12 Family <10 12 14 15> "Smith" "Smithway 17" "Smithtown"; 28 | 13 Member <-10 -11> 37 "Dennis"; 29 | 14 Member <-12 -13> 33 "Debby"; 30 | 15 Member <-14> 9 "Diana"; 31 | 16 Member <-15> 12 "Doug"; 32 | 1 HasFather; 33 | 2 HasMother; 34 | 3 HasSon; 35 | 4 HasSon; 36 | 5 HasDaughter; 37 | 6 HasFather; 38 | 7 HasMother; 39 | 8 HasDaughter; 40 | 9 HasDaughter; 41 | 10 HasFather; 42 | 11 HasSon; 43 | 12 HasMother; 44 | 13 HasDaughter; 45 | 14 HasDaughter; 46 | 15 HasSon; 47 | -------------------------------------------------------------------------------- /test/input/firm_small_46.tg: -------------------------------------------------------------------------------- 1 | // JGraLab - The Java graph laboratory 2 | // Version : unknown 3 | // Revision: unknown 4 | 5 | TGraph 2; 6 | Schema ttc.firm.SCE_Firm; 7 | GraphClass Firm; 8 | EnumDomain DM_enum_Relation ( FALSE, GREATER, EQUAL, GREATER_EQUAL, LESS, NOT_EQUAL, LESS_EQUAL, TRUE ); 9 | VertexClass Add: Binary; 10 | VertexClass And: Binary; 11 | VertexClass Argument: FirmNode { position: Integer }; 12 | abstract VertexClass Binary: FirmNode { associative: Boolean, commutative: Boolean }; 13 | VertexClass Block: FirmNode; 14 | VertexClass Cmp: Binary { relation: DM_enum_Relation }; 15 | VertexClass Cond: FirmNode; 16 | VertexClass Const: FirmNode { value: Integer }; 17 | VertexClass Div: Binary; 18 | VertexClass End: FirmNode; 19 | VertexClass EndBlock: Block; 20 | VertexClass Eor: Binary; 21 | abstract VertexClass FirmNode: Node; 22 | VertexClass Jmp: FirmNode; 23 | VertexClass Load: MemoryNode; 24 | abstract VertexClass MemoryNode: FirmNode { volatile: Boolean }; 25 | VertexClass Mod: Binary; 26 | VertexClass Mul: Binary; 27 | VertexClass Node { id: String }; 28 | VertexClass Not: FirmNode; 29 | VertexClass Or: Binary; 30 | VertexClass Phi: FirmNode; 31 | VertexClass Return: FirmNode; 32 | VertexClass Shl: Binary; 33 | VertexClass Shr: Binary; 34 | VertexClass Shrs: Binary; 35 | VertexClass Start: FirmNode; 36 | VertexClass StartBlock: Block; 37 | VertexClass Store: MemoryNode; 38 | VertexClass Sub: Binary; 39 | VertexClass SymConst: FirmNode { symbol: String }; 40 | VertexClass Sync: FirmNode; 41 | abstract EdgeClass AEdge from Node (0,0) to Node (0,0) { id: String }; 42 | EdgeClass Controlflow: FirmEdge from Node (0,0) to Node (0,0); 43 | EdgeClass Dataflow: FirmEdge from Node (0,0) to Node (0,0); 44 | EdgeClass Edge0: AEdge from Node (0,0) to Node (0,0); 45 | EdgeClass False: Controlflow from Node (0,0) to Node (0,0); 46 | EdgeClass FirmEdge: Edge0 from Node (0,0) to Node (0,0) { position: Integer }; 47 | EdgeClass Keep: FirmEdge from Node (0,0) to Node (0,0); 48 | EdgeClass Memory: Dataflow from Node (0,0) to Node (0,0); 49 | EdgeClass True: Controlflow from Node (0,0) to Node (0,0); 50 | EdgeClass UEdge: AEdge from Node (0,0) to Node (0,0); 51 | Graph "ba36cd06-7de0eae4-fc57be83-31403e71" 217 Firm (100 100 23 41); 52 | Package ; 53 | 1 Const <-2 17> "10459959534123" 10; 54 | 2 Const <-1 18> "10459959726256" 2; 55 | 3 Div <1 2 -6 28> f f "10459959886612"; 56 | 4 Const <-3 19> "10459961339101" 100; 57 | 5 Const <-4 20> "10459961401679" 50; 58 | 6 Div <3 4 -5 29> f f "10459961464257"; 59 | 7 Add <5 6 -7 30> t t "10459961690123"; 60 | 8 Const <-8 21> "10459961881768" 15; 61 | 9 Add <7 8 -11 31> t t "10459961943368"; 62 | 10 Const <-9 22> "10459962093946" 2; 63 | 11 Const <-10 23> "10459962155546" 4; 64 | 12 Mul <9 10 -12 35> t t "10459962309546"; 65 | 13 Add <11 12 -13 32> t t "10459970110258"; 66 | 14 Const <-14 24> "10459970318525" 1; 67 | 15 Add <13 14 -15 33> t t "10459970380125"; 68 | 16 Const <-16 25> "10459970856791" 15; 69 | 17 Add <15 16 34 -37> t t "10459970924747"; 70 | 18 StartBlock <-17 -18 -19 -20 -21 -22 -23 -24 -25 -26> "10459977038303"; 71 | 19 Start <26 -27 -38 -41> "10459979489592"; 72 | 20 Block <27 -28 -29 -30 -31 -32 -33 -34 -35 -36> "10459979712525"; 73 | 21 Return <36 37 38 -39> "10459980542659"; 74 | 22 EndBlock <39 -40> "10459981078481"; 75 | 23 End <40 41> "10459981299948"; 76 | 1 Dataflow "10459961169457" 1; 77 | 2 Dataflow "10459961267234" 0; 78 | 3 Dataflow "10459961501412" 0; 79 | 4 Dataflow "10459961535146" 1; 80 | 5 Dataflow "10459961782523" 1; 81 | 6 Dataflow "10459961818701" 0; 82 | 7 Dataflow "10459961979546" 0; 83 | 8 Dataflow "10459962030390" 1; 84 | 9 Dataflow "10459962398523" 0; 85 | 10 Dataflow "10459962434212" 1; 86 | 11 Dataflow "10459970210480" 1; 87 | 12 Dataflow "10459970247636" 0; 88 | 13 Dataflow "10459970415325" 0; 89 | 14 Dataflow "10459970449058" 1; 90 | 15 Dataflow "10459970963858" 1; 91 | 16 Dataflow "10459976849103" 0; 92 | 17 Dataflow "10459979012925" -1; 93 | 18 Dataflow "10459979067192" -1; 94 | 19 Dataflow "10459979099947" -1; 95 | 20 Dataflow "10459979131725" -1; 96 | 21 Dataflow "10459979163503" -1; 97 | 22 Dataflow "10459979194792" -1; 98 | 23 Dataflow "10459979243681" -1; 99 | 24 Dataflow "10459979275458" -1; 100 | 25 Dataflow "10459979307236" -1; 101 | 26 Dataflow "10459979567325" -1; 102 | 27 Controlflow "10459980105592" 0; 103 | 28 Dataflow "10459980155948" -1; 104 | 29 Dataflow "10459980187725" -1; 105 | 30 Dataflow "10459980228792" -1; 106 | 31 Dataflow "10459980265459" -1; 107 | 32 Dataflow "10459980297236" -1; 108 | 33 Dataflow "10459980328525" -1; 109 | 34 Dataflow "10459980359814" -1; 110 | 35 Dataflow "10459980392570" -1; 111 | 36 Dataflow "10459980615992" -1; 112 | 37 Dataflow "10459980649725" 1; 113 | 38 Memory "10459980893681" 0; 114 | 39 Controlflow "10459981155236" 0; 115 | 40 Dataflow "10459981371325" -1; 116 | 41 Keep "10459981607459" 0; 117 | -------------------------------------------------------------------------------- /test/input/genealogy-schema.tg: -------------------------------------------------------------------------------- 1 | // JGraLab - The Java graph laboratory 2 | // Version : 6.1.1 3 | // Codename: Falkarius 4 | 5 | TGraph 2; 6 | Schema de.genealogy.GenealogySchema; 7 | GraphClass Genealogy; 8 | EnumDomain AgeGroup (ADULT, CHILD); 9 | VertexClass Address { street: String, town: String }; 10 | VertexClass Female: Person; 11 | VertexClass Male: Person; 12 | VertexClass Person { fullName: String, ageGroup: AgeGroup }; 13 | EdgeClass HasChild: HasRelative from Person (0,2) role parents to Person (0,*) role children; 14 | EdgeClass HasRelative from Person (0,*) to Person (0,*); 15 | EdgeClass HasSpouse: HasRelative from Male (0,1) role husband to Female (0,1) role wife; 16 | EdgeClass LivesAt from Person (0,*) role persons to Address (1,1) role address; 17 | -------------------------------------------------------------------------------- /test/input/jdk-jex.tg.gz: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jgralab/funnyqt/ace568efa4ba7dcfbd9fe61d6c97890c53b58998/test/input/jdk-jex.tg.gz -------------------------------------------------------------------------------- /test/input/mintree-schema.tg: -------------------------------------------------------------------------------- 1 | TGraph 2; 2 | Schema test.mintree.MinTreeSchema; 3 | GraphClass MinTree; 4 | 5 | VertexClass Tree {value : Integer}; 6 | abstract EdgeClass HasChild from Tree (0,1) role parent to Tree (0,1) aggregation composite; 7 | EdgeClass HasLeft : HasChild from Tree (0,1) to Tree (0,1) role left aggregation composite; 8 | EdgeClass HasRight : HasChild from Tree (0,1) to Tree (0,1) role right aggregation composite; 9 | -------------------------------------------------------------------------------- /test/input/mutual-exclusion-schema.tg: -------------------------------------------------------------------------------- 1 | TGraph 2; 2 | Schema test.mutual_exclusion.MutualExclusionSchema; 3 | GraphClass MutualExclusionGraph; 4 | 5 | VertexClass Process; 6 | VertexClass Resource; 7 | 8 | EdgeClass Next from Process (0,1) role prev to Process (0,1) role next; 9 | 10 | EdgeClass Blocked from Resource (0,*) role blocked to Process (0,*) role blocker; 11 | EdgeClass HeldBy from Resource (0,*) role held to Process (0,1) role holder; 12 | EdgeClass Token from Resource (0,*) role taken to Process (0,1) role taker; 13 | EdgeClass Release from Resource (0,*) role released to Process (0,1) role releaser; 14 | EdgeClass Request from Process (0,*) role requester to Resource (0,*) role requested; 15 | -------------------------------------------------------------------------------- /test/input/polyfntestschema.tg: -------------------------------------------------------------------------------- 1 | TGraph 2; 2 | Schema funnyqt.test.polyfntest.PolyfnTestSchema; 3 | GraphClass PolyfnTestGraph; 4 | 5 | VertexClass A; 6 | VertexClass B: A; 7 | VertexClass C: A; 8 | VertexClass D: B, C; 9 | VertexClass E; 10 | VertexClass F: D, E; 11 | -------------------------------------------------------------------------------- /test/input/sierpinski-schema.tg: -------------------------------------------------------------------------------- 1 | TGraph 2; 2 | Schema test.sierpinki.SierpinskiSchema; 3 | GraphClass SierpinskiGraph; 4 | 5 | VertexClass V; 6 | 7 | EdgeClass L from V (0,3) to V (0,3); // top to left bottom 8 | EdgeClass R from V (0,3) to V (0,3); // top to right bottom 9 | EdgeClass B from V (0,3) to V (0,3); // left to right bottom 10 | 11 | -------------------------------------------------------------------------------- /test/input/uml-rdbms-bidi/classdiagram.ecore: -------------------------------------------------------------------------------- 1 | 2 | 5 | 6 | 8 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 19 | 21 | 22 | 23 | 24 | 25 | 26 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | -------------------------------------------------------------------------------- /test/input/uml-rdbms-bidi/database.ecore: -------------------------------------------------------------------------------- 1 | 2 | 5 | 6 | 8 | 9 | 10 | 11 | 13 | 15 | 16 | 17 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 28 | 29 | 30 | -------------------------------------------------------------------------------- /test/input/uml-rdbms-bidi/database.ecorediag: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | 40 | 41 | 42 | 43 | 44 | 45 | 46 | 47 | 48 | 49 | 50 | 51 | 52 | 53 | 54 | 55 | 56 | 57 | 58 | 59 | 60 | 61 | 62 | 63 | 64 | 65 | 66 | 67 | 68 | 69 | 70 | 71 | 72 | 73 | 74 | 75 | 76 | 77 | 78 | 79 | 80 | 81 | 82 | 83 | 84 | 85 | 86 | 87 | 88 | 89 | 90 | 91 | 92 | 93 | 94 | 95 | 96 | 97 | 98 | 99 | 100 | 101 | 102 | 103 | 104 | 105 | 106 | 107 | 108 | 109 | 110 | 111 | 112 | 113 | 114 | 115 | 116 | 117 | 118 | 119 | 120 | 121 | 122 | 123 | 124 | 125 | 126 | 127 | 128 | 129 | 130 | 131 | 132 | 133 | 134 | 135 | 136 | 137 | 138 | 139 | 140 | 141 | 142 | 143 | 144 | 145 | 146 | 147 | 148 | 149 | 150 | 151 | 152 | 153 | 154 | 155 | 156 | 157 | 158 | 159 | 160 | 161 | 162 | 163 | 164 | 165 | 166 | 167 | 168 | 169 | 170 | 171 | 172 | 173 | -------------------------------------------------------------------------------- /test/input/uml-rdbms-bidi/m1/classdiagram01.xmi: -------------------------------------------------------------------------------- 1 | 2 | 9 | 12 | 14 | 15 | 19 | 20 | 21 | 26 | 27 | 28 | 33 | 34 | 35 | 36 | -------------------------------------------------------------------------------- /test/input/uml-rdbms-bidi/m2/database01.xmi: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | -------------------------------------------------------------------------------- /test/input/xml-example-with-semantically-important-text.xml: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | klaus 5 | klara 6 | 7 | tick 8 | trick 9 | track 10 | 11 | 12 | 13 | klara 14 | klaus 15 | 16 | tick 17 | trick 18 | track 19 | 20 | 21 | 22 | tick 23 | klaus klara 24 | 25 | 26 | trick 27 | klaus klara 28 | 29 | 30 | track 31 | klaus klara 32 | 33 | 34 | -------------------------------------------------------------------------------- /test/input/xmltg-example-with-dtd-and-IDREFS.xml: -------------------------------------------------------------------------------- 1 | 2 | 5 | 6 | 7 | 8 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 24 | 25 | 26 | 27 | 28 | 29 | ]> 30 | 31 | 32 | 33 | Domeniquette Celeste Baudean 34 | 21 Apr 1836 35 | Unknown 36 | 37 | 38 | 39 | 40 | Jean Francois Bellau 41 | 42 | 43 | 44 | 45 | Elodie Bellau 46 | 11 Feb 1858 47 | 12 Apr 1898 48 | 49 | 50 | 51 | 52 | John P. Muller 53 | 54 | 55 | 56 | 57 | Adolf Eno 58 | 59 | 60 | 61 | 62 | Maria Bellau 63 | 64 | 65 | 66 | 67 | Eugene Bellau 68 | 69 | 70 | 71 | Louise Pauline Bellau 72 | 29 Oct 1868 73 | 3 May 1938 74 | 75 | 76 | 77 | 78 | Charles Walter Harold 79 | about 1861 80 | about 1938 81 | 82 | 83 | 84 | 85 | Victor Joseph Bellau 86 | 87 | 88 | 89 | 90 | Ellen Gilmore 91 | 92 | 93 | 94 | 95 | Honore Bellau 96 | 97 | 98 | 99 | 100 | 101 | 102 | 103 | 104 | 105 | 106 | 107 | 108 | 109 | -------------------------------------------------------------------------------- /test/input/xmltg-example-with-dtd.xml: -------------------------------------------------------------------------------- 1 | 2 | 5 | 6 | 7 | 8 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | ]> 31 | 32 | 33 | 34 | Domeniquette Celeste Baudean 35 | 21 Apr 1836 36 | Unknown 37 | 38 | 39 | 40 | 41 | Jean Francois Bellau 42 | 43 | 44 | 45 | 46 | Elodie Bellau 47 | 11 Feb 1858 48 | 12 Apr 1898 49 | 50 | 51 | 52 | 53 | John P. Muller 54 | 55 | 56 | 57 | 58 | Adolf Eno 59 | 60 | 61 | 62 | 63 | Maria Bellau 64 | 65 | 66 | 67 | 68 | Eugene Bellau 69 | 70 | 71 | 72 | Louise Pauline Bellau 73 | 29 Oct 1868 74 | 3 May 1938 75 | 76 | 77 | 78 | 79 | Charles Walter Harold 80 | about 1861 81 | about 1938 82 | 83 | 84 | 85 | 86 | Victor Joseph Bellau 87 | 88 | 89 | 90 | 91 | Ellen Gilmore 92 | 93 | 94 | 95 | 96 | Honore Bellau 97 | 98 | 99 | 100 | 101 | 102 | 103 | 104 | 105 | 106 | 107 | 108 | 109 | 110 | 111 | 112 | 113 | 114 | 115 | 116 | -------------------------------------------------------------------------------- /test/input/xmltg-example-without-dtd.xml: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | Domeniquette Celeste Baudean 6 | 21 Apr 1836 7 | Unknown 8 | 9 | 10 | 11 | 12 | Jean Francois Bellau 13 | 14 | 15 | 16 | 17 | Elodie Bellau 18 | 11 Feb 1858 19 | 12 Apr 1898 20 | 21 | 22 | 23 | 24 | John P. Muller 25 | 26 | 27 | 28 | 29 | Adolf Eno 30 | 31 | 32 | 33 | 34 | Maria Bellau 35 | 36 | 37 | 38 | 39 | Eugene Bellau 40 | 41 | 42 | 43 | Louise Pauline Bellau 44 | 29 Oct 1868 45 | 3 May 1938 46 | 47 | 48 | 49 | 50 | Charles Walter Harold 51 | about 1861 52 | about 1938 53 | 54 | 55 | 56 | 57 | Victor Joseph Bellau 58 | 59 | 60 | 61 | 62 | Ellen Gilmore 63 | 64 | 65 | 66 | 67 | Honore Bellau 68 | 69 | 70 | 71 | 72 | 73 | 74 | 75 | 76 | 77 | 78 | 79 | 80 | 81 | -------------------------------------------------------------------------------- /test/output/.keep: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/jgralab/funnyqt/ace568efa4ba7dcfbd9fe61d6c97890c53b58998/test/output/.keep --------------------------------------------------------------------------------