Commit a899898c authored by Denis Shirshov's avatar Denis Shirshov

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
parent c66c33c7
[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
Subproject commit ff8b1ba78eaee349c68614f1f528d28a0f22c203
Subproject commit 968ed0f7f40bc8199bad91b0be136b19c44c10aa
#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))))))
#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))
This diff is collapsed.
This diff is collapsed.
#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))
This diff is collapsed.
#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))
#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))
This diff is collapsed.
This diff is collapsed.
#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)))
#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