19. Removed submodule odysseus_modules. Now these files are incorporated into...

19. Removed submodule odysseus_modules. Now these files are incorporated into the pd2af project repository

.gitmodules

 [submodule "server/libs/odysseus"]
 	path = server/libs/odysseus
 	url = git@gitlab.com:ddenniss/odysseus
-[submodule "server/libs/odysseus_modules"]
-	path = server/libs/odysseus_modules
-	url = git@gitlab.com:ddenniss/odysseus_modules
-[submodule "knowledge/sb-expressions"]
-	path = knowledge/sb-expressions
-	url = git@gitlab.com:ddenniss/sb-expressions

sb-expressions @ ff8b1ba7

-Subproject commit ff8b1ba78eaee349c68614f1f528d28a0f22c203

odysseus_modules @ 968ed0f7

-Subproject commit 968ed0f7f40bc8199bad91b0be136b19c44c10aa

server/libs/odysseus_modules/pd2af/af2af.rkt

+#lang racket
+
+(require "../../odysseus/lib/_all.rkt")
+(require "../../odysseus_modules/sbgn/common.rkt")
+(require "../../odysseus_modules/sbgn/types.rkt")
+(require "../../odysseus_modules/sbgn/context.rkt")
+(require "../../odysseus_modules/sbgn/sexp.rkt")
+(require "../../odysseus_modules/sbgn/geometry.rkt")
+(require racket/syntax)
+
+(provide (all-defined-out))
+
+; element names consider equal if equal are their af-signatures
+(define (get-af-signature el)
+  (let* ((res
+          (list ($ compartment el) ($ class el) ($ name el)))
+        (res (if (ontology-uoi? ($ uoi el))
+                  (append res (list ($ uoi el)))
+                  res)))
+    res))
+
+(define (except-current-element el-id af-context)
+  (filter-not (λ (e) (equal? ($ id e) el-id)) af-context))
+
+(define-catch (remove-self-loops context)
+  (for/fold
+    ((res empty))
+    ((e context))
+    (let* ((sources ($ sources e))
+          (targets ($ targets e))
+          ; Self-looping: if element presents both in sources and targets - remove it from them
+          (sources-and-targets (if (and sources targets)
+                                    (intersect sources targets)
+                                    #f))
+          (new-sources (if sources-and-targets (minus sources targets) #f))
+          (new-targets (if sources-and-targets (minus targets sources) #f)))
+      (cond
+        ; remove whole element, if both new sources and targets empty
+        ((and (empty? new-sources) (empty? new-targets))
+          res)
+        ; remove rudimentary left-hander
+        ((and new-sources new-targets (empty? new-targets))
+          (pushr res (hash-union (hash 'sources new-sources 'targets targets) e)))
+        ; remove rudimentary right-hander (is this situation possible?)
+        ((and new-sources new-targets (empty? new-sources))
+          (pushr res (hash-union (hash 'sources sources 'targets new-targets) e)))
+        ; if no other elements to connect from sources or to targets - remove this arc:
+        ((and new-sources new-targets (and (empty? new-sources) (empty? new-targets)))
+          res)
+        ; otherwise modify its sources and targets atrributes:
+        ((and sources targets)
+          (pushr res (hash-union (hash 'sources new-sources 'targets new-targets) e)))
+        ; simply append the next non-arc element
+        (else (pushr res e))))))
+
+; remove state values from the names of AF element, if it is an only element with a 'root name'
+; e.g. A-P B C B-PP D-P D-sumo -> A B C B-PP D-P D-sumo
+(define-catch (strip-off-state-prefix-if-no-duplication context)
+  (define-catch (name-root aname)
+    (cond
+      ((not aname) aname)
+      (else
+        (let* ((parts (string-split (->string aname) "-"))
+              (root (first parts))
+              (suffixes (rest parts))
+              (suffixes (filter-not state-variable-value? suffixes)))
+          (implode (append (list root) suffixes) "-")))))
+  (define-catch (same-name-root? name1 name2)
+      (equal? (name-root name1) (name-root name2)))
+  (define-catch (get-same-namer el context)
+    (let* ((current-id ($ id el))
+          (current-name ($ name el))
+          (same-namers
+            (filter-not
+              (λ (x)
+                (or (equal? current-id ($ id x))
+                    (not (same-name-root? current-name ($ name x)))))
+            context)))
+      same-namers))
+  (for/fold
+    ((res empty))
+    ((el context))
+    (begin
+      ; (when ($ name el) (--- ($ name el) (has-variables? el) (get-same-namer el context)))
+      (cond
+        ((not (has-variables? el)) (pushr res el))
+        ((and ($ name el) (empty? (get-same-namer el context)))
+          (pushr res (hash-union (hash 'name (name-root ($ name el))) el)))
+        (else (pushr res el))))))

server/libs/odysseus_modules/pd2af/pd2af.rkt

+#lang racket
+
+(require "../../odysseus/lib/_all.rkt")
+(require "../../odysseus_modules/sbgn/types.rkt")
+(require "sbgn-ed-like-conversion.rkt")
+
+(provide pd2af)
+
+; start translation process
+(define-catch (pd2af pd-sexp-0 pd-context)
+  (let*-values (
+        ; take namespace and other non-glyph things from pd-context
+        ((af-context-0) (append
+                          (filter-not PDGlyph? pd-context)
+                          (filter Container? pd-context)))
+        ((sexp af-context) (pd2af-alg1 pd-sexp-0 af-context-0 pd-context))
+        )
+    af-context))

server/libs/odysseus_modules/pd2af/translate.rkt

+#lang racket
+
+(require "xml2pd.rkt" "pd2pd.rkt" "pd2af.rkt" "af2af.rkt" "xml2xml.rkt")
+(require "../../odysseus/lib/_all.rkt")
+(require "../../odysseus_modules/sbgn/common.rkt")
+(require "../../odysseus_modules/sbgn/types.rkt")
+(require "../../odysseus_modules/sbgn/context.rkt")
+(require "../../odysseus_modules/sbgn/sexp.rkt")
+(require "../../odysseus_modules/sbgn/geometry.rkt")
+(require "../../odysseus_modules/sbgn/sexp2ctx.rkt")
+(require "../../odysseus_modules/sbgn/ctx2xml.rkt")
+(require compatibility/defmacro)
+
+(provide (all-defined-out))
+
+(define (sort-by-names a b)
+	(cond
+		; if no compartment (compatment = #f):
+		((or (not (first a)) (not (first b)))
+			(string<? (second a) (second b)))
+		; if the same compartment:
+		((string=? (first a) (first b))
+			(string<? (second a) (second b)))
+		; order by compartments otherwise:
+		(else
+			(string<? (first a) (first b)))))
+
+(define (pd-str->pd pd-str)
+	(let* ((pd-form (read (open-input-string pd-str)))
+				(pd-context (sexp->context pd-form))
+				(pd-sexp (context->sexp pd-context))
+				(pd (HG pd-context pd-sexp)))
+		pd))
+
+(define-catch (get-af-context af-str)
+	(sexp->context (read (open-input-string af-str))))
+
+(define-catch (translate-pd pd)
+	(let* ((af-context (pd2af (HG-sexp pd) (HG-context pd))))
+    (->>
+      remove-self-loops
+			strip-off-state-prefix-if-no-duplication
+			af-context)))
+
+(define-macro (sbgn-ml->af-xml sbgn_ml)
+  `(let* (
+          ; clean incoming XML from <annotation> tag and similar things
+          (sbgn_ml (clean-sbgn-ml ,sbgn_ml))
+          ; parse SBGN ML into context and sexp
+          (pd (parse-pd-sbgn-ml sbgn_ml))
+          ; translate SBGN PD and get result in the form of AF context
+          (af-context (translate-pd pd))
+          ; generate XML from the AF context
+          (af-xml (context->xml af-context #:map-type "activity flow")))
+      af-xml))

server/libs/odysseus_modules/pd2af/xml2xml.rkt

+#lang racket
+
+(require "../../odysseus/lib/_all.rkt")
+
+(provide (all-defined-out))
+
+(define-catch (clean-sbgn-ml xml)
+  (let* ((xml (string-replace xml #px"<extension>.*?</extension>" "")))
+    xml))

server/libs/odysseus_modules/sbgn/common.rkt

+#lang racket
+
+(require "../../odysseus/lib/_all.rkt")
+(require compatibility/defmacro)
+
+(provide (all-defined-out))
+
+(define empty-values '("" "<f>" "none" "empty"))
+
+(define (empty-value? x)
+  (indexof? empty-values x))
+
+(define defaults (hash
+                    'W 1000 'H 800
+                    'el-w 110 'el-h 50
+                    'sink-w 25 'sink-h 25
+                    'gate-w 25 'gate-h 25 'gate-margin 5
+                    'process-w 15 'process-h 15
+                    'compartment-margin-x 30 'compartment-margin-y 30
+                    'compartment-w 100 'compartment-h 100
+                    'square-w 200 'square-h 100 ; side sizes of a q-grid
+                    'default-x 0 'default-y 0 ; x,y of element if not any hints (q parameter, location in the complex etc.)
+                    'component-vertical-gap 15
+                    'uoi-w 40 'uoi-h 10
+                    ; 'state-variable-positions '(70 10 40 100)
+                    'state-variable-positions '(70 10 40 25 55)
+                    'state-position 'top
+                    'state-variable-names '(P p p1 p2 Me me Ub ub Ac ac SUMO Sumo sumo state state1 state2 state3 state4 _variable)
+                    'state-variable-values '(PP ATP Ca active active1 active2 inactive inactive1 inactive2)
+                    'empty-values empty-values
+                    'state-variable-d 15 'state-variable-w 30 'state-variable-h 15
+                    ))
+
+(define reserved-keys '(id old-id in-id out-id
+                        name
+                        compartment class type
+                        sources targets
+                        cardinality
+                        uoi
+                        q qx qy x y w h
+                        x1 x2 y1 y2
+                        in-x in-y out-x out-y
+                        complex components
+                        def
+                        variables? cloned? active?))
+
+; custom geometry parameters for simple diagrams
+(define simple-generation (hash 'el-w 80 'el-h 40 'process-w 24 'process-h 24 'sink-w 50 'sink-h 50))
+(define defaults-1 (hash-union simple-generation defaults))
+
+(define default-compartment-name "default")
+
+(define context (make-parameter empty))
+(define context-compartment (make-parameter empty))
+
+(define (HG context sexp)
+  (hash 'context context 'sexp sexp))
+
+(define (HG-context pd)
+  (hash-ref pd 'context))
+
+(define (HG-sexp pd)
+  (hash-ref pd 'sexp))
+
+(define (->id id)
+  (if (re-matches? "^\\d+$" (->string id))
+    (->symbol (str "id" (->string id)))
+    (->symbol id)))
+
+(define purify-string (change-text (list
+                                      (cons "\"" "")
+                                      (cons "&quote;" ""))))
+
+(define get-element-by-id
+  (memoize
+    (λ (id context)
+      (let ((matched-elements
+              (filter
+                (λ (el) (equal? ($ id el) id))
+                context)))
+        (if (empty? matched-elements)
+          #f
+          (car matched-elements))))))
+
+; find item in the context that matches given value 1) by id 2) by any of the given keys
+(define (&& id context (keys #f))
+  (cond
+    ((or (not keys) (empty? keys))
+      (get-element-by-id id context))
+    ((scalar? keys)
+      (let ((res (filter
+                    (λ (el) (equal? (hash-ref el keys #f) id))
+                    context)))
+        (if (empty? res) #f (car res))))
+    ((list? keys)
+      (or (&& id context (car keys)) (&& id context (cdr keys))))
+    (else #f)))
+
+(define (get-pd-filename path (ext ".pd.sbgn"))
+  (let* (
+  				(filename (string-replace path "\\" "/"))
+  				(filename (string-split filename "/"))
+  				(filename (last filename))
+  				(filename (string-split filename "."))
+  				(filename (first filename))
+  				(filename (str filename ext)))
+    filename))
+
+(define (class-name class)
+  class)
+  ; (->symbol (string-replace (->string class) " " "_")))
+
+(define (id-prefix id)
+  (format "~a-" (string-replace (->string id) " " "-")))
+
+; orders sxml lists by tagname
+(define (order-by-tag tags-order sxml)
+	(sort sxml
+		(λ (a b)
+      (and (list? a) (list? b)
+  			(let* ((tag-a (car a))
+  						(tag-b (car b))
+  						(pos-a (indexof tags-order tag-a))
+  						(pos-b (indexof tags-order tag-b)))
+  				(< pos-a pos-b))))))
+
+(define-catch (ontology-uoi? uoi)
+	(and uoi
+			(re-matches? ":|ct:|mt:" uoi)))
+
+(define-catch (get-node-name el)
+  (let* ((result
+            (cond
+              ((not ($ id el)) #f)
+              ((not el) #f)
+              ((hash-empty? el) #f)
+              ((not ($ name el)) (->string ($ id el)))
+              ((scalar? ($ name el)) (->string ($ name el)))
+              ((not (list? ($ name el))) (errorf "wrong type for element's name: ~a (~a)" ($ name el) (type ($ name el))))
+              ((empty? ($ name el)) ($ id el))
+              (else (implode ($ name el) "-"))))
+          (result (and result
+                      (purify-string
+                        (first
+                          (string-split
+                            result
+                            "__")))))) ; strip off compartment appendix
+    result))
+
+(define (get-target-id el)
+  (or
+    (and ($ targets el) (car ($ targets el)))
+    ($ target el)))
+
+(define (get-target-ids el)
+  (or
+    ($ targets el)
+    (and ($ target el) (list ($ target el)))
+    empty))
+
+(define (get-target el context)
+  (&& (get-target-id el) context))
+
+(define (get-source-id el)
+  (or
+    (and ($ sources el) (car ($ sources el)))
+    ($ source el)))
+
+(define (get-source-ids el)
+  (or
+    ($ sources el)
+    (and ($ source el) (list ($ source el)))
+    empty))
+
+(define (get-context cs)
+  ($ pd-context cs))
+
+(define (get-sexp cs)
+  ($ pd-sexp cs))
+
+; frequently used for debugging output
+(define (map-id context)
+  (map (λ (x) ($ id x)) context))

server/libs/odysseus_modules/sbgn/geometry.rkt

+#lang racket
+
+(require compatibility/defmacro)
+(require "../../odysseus/lib/_all.rkt")
+(require "types.rkt")
+(require "common.rkt")
+
+(provide (all-defined-out))
+
+; layout constants
+(define W ($ el-w defaults))
+(define H ($ el-h defaults))
+(define uoiW ($ uoi-w defaults))
+(define uoiH ($ uoi-h defaults))
+(define gateW ($ gate-w defaults))
+(define gateH ($ gate-h defaults))
+(define gate-margin-0 ($ gate-margin defaults))
+(define processW ($ process-w defaults))
+(define processH ($ process-h defaults))
+
+(define-catch (mutual-disposition ax1 ay1 ax2 ay2 bx1 by1 bx2 by2)
+  (cond
+    ((> ay1 by2)
+      (cond
+        ((< ax2 bx1) 'ne)
+        ((> ax1 bx2) 'nw)
+        (else 'n)))
+    ((< ay2 by1)
+      (cond
+        ((< ax2 bx1) 'se)
+        ((> ax1 bx2) 'sw)
+        (else 's)))
+    (else
+      (cond
+        ((< ax2 bx1) 'e)
+        ((> ax1 bx2) 'w)
+        ; after case when line starts at the top of IRF1 on N018:
+        ((< (abs (- ax1 bx1)) (abs (- ax2 bx2))) 'w)
+        ; (else 'overlap)
+        (else 'e)))))
+
+(define-catch (diagonal-quadrant x1 y1 x2 y2)
+  (cond
+    ((and (> x2 x1) (> (- x2 x1) (abs (- y2 y1))))
+      'e)
+    ((and (< x2 x1) (> (- x1 x2) (abs (- y2 y1))))
+      'w)
+    ((and (> y1 y2) (> (- y1 y2) (abs (- x2 x1))))
+      'n)
+    (else 's)))
+
+(define-catch (c x1 x2 y1 y2)
+  (list (/ (+ x1 x2) 2.0) (/ (+ y1 y2) 2.0)))
+
+(define-catch (mass-center elements)
+  (cond
+    ((empty? elements) (hash 'x 0 'y 0))
+    (else
+      (let ((n (* 1.0 (length elements))))
+        (let loop ((xc 0) (yc 0) (elements elements))
+          (cond
+            ((empty? elements) (hash 'x (/ xc n) 'y (/ yc n)))
+            (else
+              (let* (
+                    (e (car elements))
+                    (x (or (->number ($ x e)) 0))
+                    (y (or (->number ($ y e)) 0))
+                    (w (or (->number ($ w e)) ($ el-w defaults)))
+                    (h (or (->number ($ h e)) ($ el-h defaults)))
+                    (exc (+ x (/ w 2.0)))
+                    (eyc (+ y (/ h 2.0))))
+                (loop (+ xc exc) (+ yc eyc) (cdr elements))))))))))
+
+(define-catch (get-node-xy-in-the-middle elements)
+  (let* (
+  			(coors-center-xy (mass-center elements))
+  			(xc ($ x coors-center-xy))
+  			(yc ($ y coors-center-xy))
+  			(x (- xc (/ gateW 2.0)))
+  			(y (- yc (/ gateH 2.0))))
+    (hash 'x x 'y y)))
+
+(define-catch (centrify el-w el-h box-x box-y box-w box-h)
+  (hash
+    'x (+ box-x (/ box-w 2.0) (/ el-w -2.0))
+    'y (+ box-y (/ box-h 2.0) (/ el-h -2.0))))
+
+(define-catch (calculate-arc-coors x1 y1 w1 h1 x2 y2 w2 h2 (d #f))
+  (and x1 y1 w1 h1 x2 y2 w2 h2
+    (let* (
+          (x1 (->number x1)) (y1 (->number y1)) (w1 (->number w1)) (h1 (->number h1)) (x2 (->number x2)) (y2 (->number y2)) (w2 (->number w2)) (h2 (->number h2))
+          (mutual-disp (mutual-disposition x1 y1 (+ x1 w1) (+ y1 h1) x2 y2 (+ x2 w2) (+ y2 h2)))
+          (arc-coors
+            (case mutual-disp
+              ((n ne nw overlap) `(,@(c x1 (+ x1 w1) y1 y1) ,@(c x2 (+ x2 w2) (+ y2 h2) (+ y2 h2))))   ; top-center -> bottom-center
+              ((e) `(,@(c (+ x1 w1) (+ x1 w1) y1 (+ y1 h1)) ,@(c x2 x2 y2 (+ y2 h2))))   ; right-center -> left-center
+              ((w) `(,@(c x1 x1 y1 (+ y1 h1)) ,@(c (+ x2 w2) (+ x2 w2) y2 (+ y2 h2))))   ; left-center -> right-center
+              ((s se sw) `(,@(c x1 (+ x1 w1) (+ y1 h1) (+ y1 h1)) ,@(c x2 (+ x2 w2) y2 y2)))   ; bottom-center -> top-center
+            )))
+      (hash 'x1 (first arc-coors) 'y1 (second arc-coors) 'x2 (third arc-coors) 'y2 (fourth arc-coors)))))
+
+(define-catch (calculate-port-coors sources x y (gate-margin gate-margin-0) #:w (w gateW) #:h (h gateH))
+  (let* (
+        (average-source-coors (mass-center sources))
+        (average-source-x ($ x average-source-coors))
+        (average-source-y ($ y average-source-coors))
+        (source-disposition (diagonal-quadrant x y average-source-x average-source-y))
+        (result
+          (case source-disposition
+            ((n)
+              (hash
+                    'port-in-x (+ x (/ w 2.0))
+        				    'port-in-y (- y gate-margin)
+        				    'port-out-x (+ x (/ w 2.0))
+        				    'port-out-y (+ y h gate-margin)))
+            ((e)
+              (hash
+                    'port-in-x (+ x w gate-margin)
+        				    'port-in-y (+ y (/ h 2.0))
+        				    'port-out-x (- x gate-margin)
+        				    'port-out-y (+ y (/ h 2.0))))
+            ((w)
+              (hash
+        				    'port-in-x (- x gate-margin)
+        				    'port-in-y (+ y (/ h 2.0))
+                    'port-out-x (+ x w gate-margin)
+                    'port-out-y (+ y (/ h 2.0))))
+            ((s)
+              (hash
+        				    'port-in-x (+ x (/ w 2.0))
+        				    'port-in-y (+ y h gate-margin)
+                    'port-out-x (+ x (/ w 2.0))
+                    'port-out-y (- y gate-margin))))))
+    result))
+
+(define-catch (get-line-between source target)
+    (cond
+      ((and (ActivityLogicalOperator? source) (ActivityLogicalOperator? target))
+        (hash 'x1 ($ out-x source) 'y1 ($ out-y source) 'x2 ($ in-x target) 'y2 ($ in-y target)))
+      ((and (ActivityLogicalOperator? source) (ActivityNode? target))
+        (let* ((coors (calculate-arc-coors
+                      ($ out-x source) ($ out-y source) 1 1
+                      ($ x target) ($ y target) ($ w target) ($ h target)))
+                (x2 ($ x2 coors))
+                (y2 ($ y2 coors))
+                )
+          (hash 'x1 ($ out-x source) 'y1 ($ out-y source) 'x2 x2 'y2 y2)))
+      ((and (ActivityNode? source) (ActivityLogicalOperator? target))
+        (let* ((coors (calculate-arc-coors
+                        ($ x source) ($ y source) ($ w source) ($ h source)
+                        ($ in-x target) ($ in-y target) 1 1))
+                (x1 ($ x1 coors))
+                (y1 ($ y1 coors))
+                )
+          (hash 'x1 x1 'y1 y1 'x2 ($ in-x target) 'y2 ($ in-y target))))
+      ((and (ActivityNode? source) (ActivityNode? target)
+          (calculate-arc-coors
+            ($ x source) ($ y source) ($ w source) ($ h source)
+            ($ x target) ($ y target) ($ w target) ($ h target))))
+      (else #f)))

server/libs/odysseus_modules/sbgn/sexp.rkt

+#lang racket
+
+(require "../../odysseus/lib/_all.rkt")
+(require "common.rkt")
+(require "types.rkt")
+
+(provide (all-defined-out))
+
+(define (subst-ids old-ids new-id sexp)
+  (for/fold
+    ((res sexp))
+    ((old-id old-ids))
+    (for/list
+      ((triplet res))
+      (match triplet
+        (`(,(list-no-order (== old-id) rest ...) ,id2 ,id3)
+              `((,new-id ,@rest) ,id2 ,id3))
+        (`(,(== old-id) ,id2 ,id3)
+              `(,new-id ,id2 ,id3))
+
+        ; commented to avoid overwriting processes, after which doubles appears in the sexp
+        ; (`(,id1 ,(list-no-order (== old-id) rest ...) ,id3)
+        ;       `(,id1 (,new-id ,@rest) ,id3))
+        ; (`(,id1 ,(== old-id) ,id3)
+        ;       `(,id1 ,new-id ,id3))
+
+        (`(,id1 ,id2 ,(list-no-order (== old-id) rest ...))
+              `(,id1 ,id2 (,new-id ,@rest)))
+        (`(,id1 ,id2 ,(== old-id))
+              `(,id1 ,id2 ,new-id))
+
+        (else triplet)))))
+
+;; sexp modification
+(define (replace-ids sexp ids id)
+  (let loop ((sexp sexp) (ids ids))
+    (cond
+      ((empty? ids) sexp)
+      (else
+        (loop (replace-by-part sexp (car ids) id) (cdr ids))))))
+
+(define (exclude-id sexp id)
+  (tree-clean
+    not-empty-list?
+    empty?
+    (tree-exclude sexp id)))
+
+(define (replace-triplet sexp sample-triplet target-triplet)
+  (for/fold
+    ((sexp-res (list)))
+    ((triplet sexp))
+    (cond
+      ((equal? triplet sample-triplet) (pushr sexp-res target-triplet))
+      (else (pushr sexp-res triplet)))))
+
+(define (@@<> sample-triplet target-triplet sexp )
+  (replace-triplet sexp sample-triplet target-triplet))
+
+(define (remove-triplet sexp sample-triplet)
+  (let ((id-to-delete (second sample-triplet)))
+    (tree-exclude