Permalink
Switch branches/tags
Nothing to show
Find file Copy path
Fetching contributors…
Cannot retrieve contributors at this time
962 lines (870 sloc) 35.2 KB
(ns ewan.eaf30.core
(:require [cljs.spec.alpha :as s]
[clojure.data.xml :as xml]
[clojure.string :as string]
[clojure.zip :as z]
[cljs.test]
[re-frame.core :as rf]
[ewan.common :refer [children attrs tag-name]]
[ewan.eaf30.spec :as spec])
(:require-macros [cljs.spec.alpha :as s]
[cljs.test :refer [is]]
[ewan.eaf30.macros :refer [defzipfn defzipfn-]]))
;; ----------------------------------------------------------------------------
;; Conversion functions
;; ----------------------------------------------------------------------------
;; Internally, we will be using a Hiccup-like representation of EAF as it is
;; losslessly serializable to JSON. Whenever we need to generate EAF for the
;; user, we will use hiccup->eaf-str, and whenever we need to ingest EAF, we
;; will use eaf-str->hiccup. Note that unlike normal Hiccup, non-terminal nodes
;; in this representation MUST have a map present for attributes, even if it
;; is empty, to align with the conventions of clojure.data.xml.
(defn- snake->kebab
[kwd]
(-> kwd
name
(string/lower-case)
(string/replace #"_" "-")
keyword))
(defn- kebab->snake
[kwd]
(-> kwd
name
(string/upper-case)
(string/replace #"-" "_")
keyword))
(defn- xml->hiccup
"Take EAF XML generated by clojure.data.xml and generate equivalent hiccup.
For tags and attribute names, which data.xml turns into keywords, it also
converts their names from :CAPS_SNAKE_CASE into :kebab-case"
[node]
(if-not (xml/element? node)
node
(let [tag (snake->kebab (:tag node))
attrs (->> (:attrs node)
;; filter out this attr--see note below under EAF 3.0 spec
(filter (fn [[k _]] (not= (name k)
"noNamespaceSchemaLocation")))
(map (fn [[k v]] [(snake->kebab k) v]))
(into {}))
content (map xml->hiccup (:content node))]
(into [tag attrs] content))))
(defn- hiccup->xml
"Take the Hiccup-like XML representation used internally by ewan and turn it
back into XML in anticipation of serialization. Reverts :kebab-case tags into
:CAPS_SNAKE_CASE."
[hiccup]
(if-not (vector? hiccup)
hiccup
(let [tag (kebab->snake (first hiccup))
attrs (->> (second hiccup)
(map (fn [[k v]] [(kebab->snake k) v]))
(into {}))
content (map hiccup->xml (drop 2 hiccup))]
(apply xml/element (into [tag attrs] content)))))
;; NOTE: this is NOT a correct solution. For one thing, XML is a context-free
;; language while we're attempting to parse it using a regular expression.
;; One possible error this could introduce: it gets rid of the content of any
;; inner content that might match /\s+/, such as `<p> </p>`.
;; Ideally this would be handled using an XSLT transform, but I'm not sure how
;; to do that conveniently.
;; Cf: https://stackoverflow.com/questions/10549290/what-would-be-the-regular-expression-to-remove-whitespaces-between-tags-only-in?noredirect=1&lq=1
(defn- unsafe-remove-whitespace
[str]
(string/replace str #">\s+<" "><"))
(defn- add-annotation-document-attrs
"A hack necessary to restore attributes on the XML string since
clojure.data.xml was too inconvenient to work with. Takes something like
<?xml version=\"1.0\" encoding=\"UTF-8\"?>
<ANNOTATION_DOCUMENT [...]>
and turns it into
<?xml version=\"1.0\" encoding=\"UTF-8\"?>
<ANNOTATION_DOCUMENT [...]
xmlns:xsi=\"http://www.w3.org/2001/XMLSchema-instance\"
xsi:noNamespaceSchemaLocation=\"http://www.mpi.nl/tools/elan/EAFv2.8.xsd\">"
[xml-str]
(string/replace-first
xml-str
"<ANNOTATION_DOCUMENT "
"<ANNOTATION_DOCUMENT xmlns:xsi=\"http://www.w3.org/2001/XMLSchema-instance\" xsi:noNamespaceSchemaLocation=\"http://www.mpi.nl/tools/elan/EAFv2.8.xsd\" "))
;; public conversion funcs -----------------------------------------------------
(defn eaf-str->hiccup
"Takes the raw text of an EAF file, parses it into XML, and gives the hiccup
analog of that XML."
[str]
(-> str
unsafe-remove-whitespace
xml/parse-str
xml->hiccup))
(defn hiccup->eaf-str
"Takes hiccup representation of an EAF file, turns it into XML, and gives
the EAF file string, without indentation."
[hiccup]
(-> hiccup
hiccup->xml
xml/emit-str
add-annotation-document-attrs))
(defn eaf?
"Tests whether the hiccup supplied conforms to the EAF 3.0 spec"
[hiccup]
(s/valid? ::spec/annotation-document hiccup))
(defn create-eaf
"Creates a new, minimal set of EAF 3.0 hiccup, roughly mimicking what
ELAN 5.1 does when it creates a fresh project."
[{:keys [:author :date :media-descriptors]}]
[:annotation-document {:author author
:date date
:format "3.0"
:version "3.0"}
(-> [:header {:media-file ""
:time-units "milliseconds"}]
;; append media descriptors
(into (for [{:keys [:media-url :mime-type]} media-descriptors]
[:media-descriptor {:media-url media-url
:mime-type mime-type}]))
(conj [:property {:name "lastUsedAnnotationId"} "0"]))
[:time-order {}]
[:tier {:linguistic-type-ref "default-lt"
:tier-id "default"}]
[:linguistic-type {:graphic-references "false"
:linguistic-type-id "default-lt"
:time-alignable "true"}]
[:constraint
{:description "Time subdivision of parent annotation's time interval, no time gaps allowed within this interval"
:stereotype "Time_Subdivision"}]
[:constraint
{:description "Symbolic subdivision of a parent annotation. Annotations refering to the same parent are ordered"
:stereotype "Symbolic_Subdivision"}]
[:constraint
{:description "1-1 association with a parent annotation"
:stereotype "Symbolic_Association"}]
[:constraint
{:description "Time alignable annotations within the parent annotation's time interval, gaps are allowed"
:stereotype "Included_In"}]])
;; ----------------------------------------------------------------------------
;; zip helper funcs
;; ----------------------------------------------------------------------------
;; Internally, we will use clojure.zip, as it's probably the most ergonomic way
;; of manipulating this rather large hiccup structure. The public API for this
;; module, however, will never expose a zipper to consumers.
(defn- hiccup-zipper
"Returns a zipper for Hiccup forms, given a root form."
[root]
(let [children-pos #(if (map? (second %)) 2 1)]
(z/zipper
vector?
#(drop (children-pos %) %) ; get children
#(into [] (concat (take (children-pos %1) %1) %2)) ; make new node
root)))
(defn- right-while
"Call z/right while (pred (z/node zipper)) is true"
[loc pred]
(when loc
(when-let [node (z/node loc)]
(if (pred node)
(recur (z/right loc) pred)
loc))))
(defn- right-while-some
"Call z/right while (pred (z/node zipper)) is true AND (z/right zipper) is
not nil"
[loc pred]
(when loc
(when-let [node (z/node loc)]
(if (and (pred node) (-> loc z/right nil? not))
(recur (z/right loc) pred)
loc))))
(defn- left-while
"Call z/left while (pred (z/node loc)) is true"
[loc pred]
(when loc
(when-let [node (z/node loc)]
(if (pred node)
(recur (z/left loc) pred)
loc))))
(defn- take-right-while
"Returns a seq of contiguous nodes beginning from the current node and going
right such that (pred node) is satisfied for all in the sequence"
[loc pred]
(when loc
(when-let [node (z/node loc)]
(when (pred node)
(cons node (take-right-while (z/right loc) pred))))))
(defn- update-right-while
"Like right-while, but also updates each node that tests true with
the value of (func (z/node loc))"
[loc pred func]
(when loc
(when-let [node (z/node loc)]
(if (pred node)
(recur (z/right (z/replace loc (func node))) pred func)
loc))))
(defn- right-to-first
[loc kwd]
(right-while loc #(not= (tag-name %) kwd)))
(defn- take-right-to-last
[loc kwd]
(take-right-while loc #(= (tag-name %) kwd)))
;; ----------------------------------------------------------------------------
;; Foundational `go-to` functions
;; ----------------------------------------------------------------------------
;; defzipfn is a macro that generates something like this:
;; (defn <name> [hiccup] (-> hiccup hiccup-zipper <arg1> <arg2> ...))
;; Functions prefixed with `go-to` return a `zip` location, or `nil` if no
;; appropriate element could be found
(defzipfn- go-to-annotation-document) ;; do nothing
(defzipfn- go-to-licenses z/down (right-to-first :license))
(defzipfn- go-to-header z/down (right-to-first :header))
(defzipfn- go-to-time-order z/down (right-to-first :time-order))
(defzipfn- go-to-tiers z/down (right-to-first :tier))
(defzipfn- go-to-linguistic-types z/down (right-to-first :linguistic-type))
(defzipfn- go-to-locales z/down (right-to-first :locale))
(defzipfn- go-to-languages z/down (right-to-first :language))
(defzipfn- go-to-constraints z/down (right-to-first :constraint))
(defzipfn- go-to-controlled-vocabularies z/down (right-to-first :controlled-vocabulary))
(defzipfn- go-to-lexicon-refs z/down (right-to-first :lexicon-ref))
(defzipfn- go-to-external-refs z/down (right-to-first :external-ref))
;; ----------------------------------------------------------------------------
;; Trivial `get-` functions
;; ----------------------------------------------------------------------------
(defzipfn get-date z/node attrs :date)
(defzipfn get-author z/node attrs :author)
(defzipfn get-version z/node attrs :version)
(defn get-licenses
"Returns a seq of all license elements"
[hiccup]
(-> hiccup
go-to-licenses
(take-right-to-last :license)))
(defn get-media-descriptors
"Returns a seq of all media-descriptor elements (under the header element)"
[hiccup]
(-> hiccup
go-to-header
z/down
(take-right-to-last :media-descriptor)))
(defn get-properties
"Returns a seq of all property elements (under the header element)"
[hiccup]
(-> hiccup
go-to-header
z/down
(right-to-first :property)
(take-right-to-last :property)))
(defn get-tiers
"Returns a seq of all tier elements"
[hiccup]
(-> hiccup
go-to-tiers
(take-right-to-last :tier)))
(defn get-locales
"Returns a seq of all locales"
[hiccup]
(-> hiccup
go-to-locales
(take-right-to-last :locale)))
(defn get-linguistic-types
"Returns a seq of all linguistic types"
[hiccup]
(-> hiccup
go-to-linguistic-types
(take-right-to-last :linguistic-type)))
(defn get-controlled-vocabularies
"Returns a seq of all controlled vocabularies"
[hiccup]
(-> hiccup
go-to-controlled-vocabularies
(take-right-to-last :controlled-vocabulary)))
(defn get-time-slots
"Returns a seq of all time slots under the :time-order element"
[hiccup]
(-> hiccup
go-to-time-order
z/children))
(defn get-alignable-annotations
"Returns a seq of all alignable annotations"
[hiccup]
(->> hiccup
get-tiers ;; seq of tiers
(mapcat children) ;; grab all :annotations and put into single seq
(map (comp first children)) ;; discard outer :annotation element
(filter #(= (tag-name %) :alignable-annotation))))
;; NYI: get-* for some top-level elements like :constraint
;; derived data structures and cache
;; ----------------------------------------------------------------------------
;; Non-trivial getters and setters rely on data that is most efficiently
;; obtained from data structures that are derived from the XML.
;; Most of the time, we don't care about an old hiccup structure after we've
;; encountered a new one, so we keep track of the latest one we've seen in
;; `:latest-doc` and cache derived structures with the other keys in `*cache*`.
;;
;; Functions that rely on derived structures call functions which are
;; suffixed with `map-`. These functions check to see if the hiccup
;; they're given matches `:latest-doc` and then either just return
;; the cached derived structure if it's the same, or build a new version
;; if it's different and set the appropriate var.
;;
;; From an external perspective, this approach is still functionally
;; pure and preserves referential transparency. It just gets us a
;; performance win a lot of the time.
(defn get-time-slot-val [hiccup time-slot-id]
"Determine the millisecond value of a time slot ID."
(when-let [loc (-> hiccup
go-to-time-order
z/down
(right-while
#(not= time-slot-id (:time-slot-id (attrs %)))))]
;; TODO: find out why :time-value is sometimes allowed to be null
;; for now, just interpolate between the two neighboring time slots
;; with time-value values
(or (-> loc z/node attrs :time-value)
(let [left-neighbor-val
(or (-> loc
(left-while #(not (some? (:time-value (attrs %)))))
z/node
attrs
:time-value)
0)
right-neighbor-val
(-> loc
(right-while #(not (some? (:time-value (attrs %)))))
z/node
attrs
:time-value)]
(str (/ (+ (int left-neighbor-val)
(int right-neighbor-val))
2))))))
(defn- annotation-map-uncached
[hiccup]
(into
{}
(for [tier (get-tiers hiccup)
ann (children tier)]
(let [inner-ann (first (children ann))
type (tag-name inner-ann)
{:keys [:annotation-id
:annotation-ref
:time-slot-ref1
:time-slot-ref2]} (attrs inner-ann)
tier-id (-> tier attrs :tier-id)]
[annotation-id
(merge {:tier-id tier-id
:value (-> inner-ann children first children first)}
(if annotation-ref
{:ref annotation-ref}
{:time1 (get-time-slot-val hiccup time-slot-ref1)
:time2 (get-time-slot-val hiccup time-slot-ref2)}))]))))
(defn- tier-map-uncached
"map from tier-id's to information about the tier"
[hiccup]
(into {}
(for [{:keys [tier-id parent-ref linguistic-type-ref]}
(map attrs (get-tiers hiccup))]
[tier-id {:parent-ref parent-ref
:linguistic-type-ref linguistic-type-ref}])))
(defn- linguistic-type-map-uncached
"map from linguistic type id's to information about the type"
[hiccup]
(into {}
(for [{:keys [linguistic-type-id
time-alignable
constraints
controlled-vocabulary-ref]}
(map attrs (get-linguistic-types hiccup))]
[linguistic-type-id {:time-alignable time-alignable
:constraints constraints
:controlled-vocabulary-ref controlled-vocabulary-ref}])))
(defn- controlled-vocabulary-map-uncached
"map from controlled vocabulary id's to information about the cv"
[hiccup]
(into {}
(for [cv (get-controlled-vocabularies hiccup)]
(let [id (-> cv attrs :cv-id)
entries (->> cv
children
(filter #(= (first %) :cv-entry-ml))
(map (fn [[_ {:keys [cve-id]}
[_ {:keys [description]}
value]]]
{:id cve-id
:description description
:value value})))]
[id entries]))))
(declare get-tier-of-ann)
(defn- time-slot-map-uncached
"map from time slot id's to their values and tiers that use them"
[hiccup]
(let [alignable-annotations (get-alignable-annotations hiccup)]
(into {}
(for [ts (get-time-slots hiccup)]
(let [{:keys [time-slot-id time-value]} (attrs ts)
used-in (->> alignable-annotations
(filter #(or (= time-slot-id (-> % attrs :time-slot-ref1))
(= time-slot-id (-> % attrs :time-slot-ref2))))
(map (comp :annotation-id attrs))
(map #(get-tier-of-ann hiccup %))
(into #{}))]
[time-slot-id {:value time-value
:used-in used-in}])))))
(def ^:private *cache* {:latest-doc nil
:annotation-map nil
:tier-parent-map nil
:linguistic-type-map nil
:controlled-vocabulary-map nil
:time-slot-map nil})
(defn- update-cache!
[hiccup]
(set! *cache* {:latest-doc
hiccup
:annotation-map
(annotation-map-uncached hiccup)
:tier-map
(tier-map-uncached hiccup)
:linguistic-type-map
(linguistic-type-map-uncached hiccup)
:controlled-vocabulary-map
(controlled-vocabulary-map-uncached hiccup)})
;; time-slot-map depends on annotation-map
(set! *cache* (assoc *cache* :time-slot-map (time-slot-map-uncached hiccup))))
(defn- make-cached
[ckey]
(fn [hiccup]
(when-not (= (:latest-doc *cache*) hiccup)
(update-cache! hiccup))
(ckey *cache*)))
(def ^:private annotation-map (make-cached :annotation-map))
(def ^:private tier-map (make-cached :tier-map))
(def ^:private linguistic-type-map (make-cached :linguistic-type-map))
(def ^:private controlled-vocabulary-map (make-cached :controlled-vocabulary-map))
(def ^:private time-slot-map (make-cached :time-slot-map))
;; ----------------------------------------------------------------------------
;; More involved getters
;; ----------------------------------------------------------------------------
;; tier getters ----------------------------------------------------------------
(defn- go-to-tier
[hiccup tier-id]
(-> hiccup
go-to-tiers
(right-while #(not= (-> % attrs :tier-id) tier-id))))
(defn get-parent-tiers
"Given a tier ID, return a seq of parent tiers"
[hiccup tier-id]
(let [tiers (tier-map hiccup)
inner (fn inner [id]
(let [{:keys [parent-ref]} (get tiers id)]
(if parent-ref
(cons parent-ref (inner parent-ref))
nil)))]
(inner tier-id)))
(defn is-parent-tier
"Given a tier ID, return true if there are other tiers
that refer to it with :parent-ref; nil otherwise"
[hiccup tier-id]
(->> hiccup
tier-map
(some (fn [[child {:keys [parent-ref]}]]
(= parent-ref tier-id)))))
(defn has-controlled-vocabulary
"True if the tier has a linguistic type that references
a controlled vocabulary, indicating that the tier's annotations
are not in freetext; false otherwise"
[hiccup tier-id]
(let [lt-id (-> (tier-map hiccup)
(get tier-id)
(:linguistic-type-ref))
lt (-> (linguistic-type-map hiccup)
(get lt-id))]
(some? (:controlled-vocabulary-ref lt))))
(defn get-controlled-vocabulary-entries
"Given a TIER id, returns a seq of all the entries under the
controlled vocabulary that is referenced by the linguistic
type of the tier. Each entry of the seq has keys :value
and :description."
[hiccup tier-id]
(let [lt-id (-> (tier-map hiccup)
(get tier-id)
:linguistic-type-ref)
cv-id (-> (linguistic-type-map hiccup)
(get lt-id)
:controlled-vocabulary-ref)]
(get (controlled-vocabulary-map hiccup) cv-id)))
(defn get-tier-constraint
"Given a tier id, returns the value of the :constraints attribute
of its linked linguistic type if it is present, else nil"
[hiccup tier-id]
{:post [(or (nil? %) (s/valid? ::spec/stereotype %))]}
(->> tier-id
(get (tier-map hiccup))
:linguistic-type-ref
(get (linguistic-type-map hiccup))
:constraints))
;; annotation getters ---------------------------------------------------------
(defn get-tier-of-ann
"Returns the ID of the tier that holds the annotation, or nil
if the annotation doesn't exist"
[hiccup ann-id]
(let [map (annotation-map hiccup)]
(some-> (get map ann-id)
:tier-id)))
(defn- go-to-annotation
"Returns a zipper that has been taken to the annotation element
with the given ID. Note that this does not return the outer
:annotation element. It returns the element with the actual ID
on it, i.e. an :alignable-annotation or a :ref-annotation"
[hiccup ann-id]
(let [tier-id (get-tier-of-ann hiccup ann-id)]
(-> hiccup
(go-to-tier tier-id)
z/down
(right-while #(not= (-> % children first attrs :annotation-id)
ann-id))
z/down)))
(defn get-annotation-times
"Returns a map with keys :time1 :time2 representing the millisecond time
for a given annotation. If the annotation is a reference annotation, its
times are recursively resolved."
[hiccup ann-id]
(let [{:keys [ref] :as m}
(get (annotation-map hiccup) ann-id)]
(if ref
(recur hiccup ref)
m)))
(defn get-annotation-value
"Returns the value of an annotation"
[hiccup ann-id]
(-> (annotation-map hiccup)
(get ann-id)
:value))
;; ----------------------------------------------------------------------------
;; setters
;; ----------------------------------------------------------------------------
;; id helpers -----------------------------------------------------------------
(defn- sort-by-id-num
[s]
(sort (fn [a b]
(compare (int (re-find #"\d+" a))
(int (re-find #"\d+" b))))
s))
(defn- make-incr-id
"Given a string like \"a99\", returns \"a100\". The returned string always
begins with \"a\", even if an \"a\" was not present in the provided string.
If the provided string does not have an identifiable sequence of numbers,
\"a1\" is returned."
[prefix]
(fn [id]
(->> id
(re-find #"\d+")
int ;; (int nil) => 0
inc
(str prefix))))
(defn- id-numbers-are-contiguous
"Given a sorted seq of ids, returns the greatest number if they are contiguous,
or false if they are not contiguous. (An empty seq is contiguous.)"
[s]
(reduce (fn [acc id]
(if (and acc
(= (- (js/parseInt (re-find #"\d+" id))
acc)
1))
(inc acc)
false))
0
s))
(def ^:private incr-ann-id (make-incr-id "a"))
(def ^:private incr-ts-id (make-incr-id "ts"))
(defn- make-next-id
"Determines what the next annotation ID to be used ought to be. Regardless
of whatever annotation ID conventions may be present in the file, it always
returns an ID of the form `<prefix>[0-9]+`. The returned ID is guaranteed to not
to occur in any existing annotation."
[prefix map-func incr-id-func]
(fn [hiccup]
(let [last-id (some->> hiccup
map-func
keys
sort-by-id-num
last)
map (map-func hiccup)]
(if (nil? last-id)
(str prefix "1")
(loop [next-id last-id]
(if (nil? (get map next-id))
next-id
(recur (incr-id-func next-id))))))))
(def ^:private next-annotation-id (make-next-id "a" annotation-map incr-ann-id))
(def ^:private next-time-slot-id (make-next-id "ts" time-slot-map incr-ts-id))
;; time slot id management (internal) -----------------------------------------
(defn- update-time-slots-after-insertion
[hiccup]
(let [id-at-loc #(-> % z/node attrs :time-slot-id)]
(loop [loc (-> hiccup go-to-time-order z/down)
prev-id nil
old-to-new {}]
(cond
;; reached the new time slot, or we've already encountered it
(or (= (id-at-loc loc) "**REPLACEME**")
(get old-to-new "**REPLACEME**"))
(let [old-id (id-at-loc loc)
new-id (incr-ts-id prev-id)
new-node (-> loc
z/node
(update 1 assoc :time-slot-id new-id))
new-loc (-> loc (z/replace new-node))]
(if (nil? (z/right new-loc))
[(z/root new-loc) (assoc old-to-new old-id new-id)]
(recur (z/right new-loc) new-id (assoc old-to-new old-id new-id))))
;; haven't reached the new time slot yet--id is identical so we don't record it
:else
(recur (z/right loc) (id-at-loc loc) old-to-new)))))
(defn- update-time-slots-after-deletion
[hiccup]
;; nyi
[hiccup {}])
(defn- update-time-slot-refs
[hiccup old-to-new]
(letfn [(replace-ref [ref]
(or (get old-to-new ref) ref))
(process-ann [loc]
(let [[_ _
[ann-type
{:keys [time-slot-ref1
time-slot-ref2] :as attrs}
_] :as node] (z/node loc)]
(if (= ann-type :alignable-annotation)
(let [new-attrs (-> attrs
(update :time-slot-ref1 replace-ref time-slot-ref1)
(update :time-slot-ref2 replace-ref time-slot-ref2))]
(z/replace loc (assoc-in node [2 1] new-attrs)))
loc)))
(process-tier [loc]
(if-not (z/children loc)
loc
(loop [loc (z/down loc)]
(if (z/right loc)
(recur (-> loc process-ann z/right))
(-> loc process-ann z/up)))))]
(loop [loc (go-to-tiers hiccup)]
(if (and (z/right loc)
(-> loc z/right z/node tag-name (= :tier)))
(recur (-> loc process-tier z/right))
(-> loc process-tier z/root)))))
(defn- reassign-time-slot-ids
"ELAN maintains at least a couple constraints on time slots:
1. TSIDs are contiguous positive integers
2. time slots have monotonically increasing time values (if present)
For this reason, whenever an annotation is deleted or created, this
function needs to be called so we can enforce these constraints.
Note that this function assumes that there was AT MOST one addition or
deletion. It also assumes that TSIDs are 1-indexed."
[hiccup]
{:pre [(eaf? hiccup)]
:post [(eaf? %)]}
;; 1. check for gap in numbers, or id like **REPLACE**
(let [tsm (time-slot-map hiccup)
sorted-tsids (-> tsm keys sort-by-id-num)]
(cond
;; insertion
(get tsm "**REPLACEME**")
(let [[hiccup old-to-new] (update-time-slots-after-insertion hiccup)]
(update-time-slot-refs hiccup old-to-new))
;; deletion
(not (id-numbers-are-contiguous sorted-tsids))
(let [[hiccup old-to-new] (update-time-slots-after-deletion hiccup)]
(update-time-slot-refs hiccup old-to-new))
:else
(js/Error.
"Tried to reassign time slot IDs, but no insertion or deletion was found."))))
(defn- time-slot
[value]
{:pre [(and (string? value)
(re-matches #"^\d+$" value))]}
[:time-slot {:time-slot-id "**REPLACEME**"
:time-value value}])
(defn- insert-new-time-slot
"Given a set of hiccup and a millisecond value, creates and inserts
a new time slot with id **REPLACEME**. You MUST call
`reassign-time-slot-ids` after this to ensure that the temporary ID
is replaced before any hiccup is returned to consuming code."
[hiccup ms]
{:pre [(and (string? ms) (re-matches #"^\d+$" ms))
(eaf? hiccup)]
:post [(eaf? %)]}
(let [loc (-> hiccup
go-to-time-order
z/down
(right-while-some
#(>= (js/parseInt ms)
(-> % attrs :time-value js/parseInt))))
node (time-slot ms)]
(if (< (js/parseInt ms)
(-> loc z/node attrs :time-value js/parseInt))
(-> loc (z/insert-left node) z/root)
(-> loc (z/insert-right node) z/root))))
(defn- find-or-create-time-slot
"Given a time (in seconds), attempts to find a time slot used by the
tier or one of its parents. If a suitable time slot ID isn't found,
a new one is created and time slot id's are reassigned. For this reason,
we also need to return the updated annotation document along with the id"
[hiccup tier-id time]
{:pre [(eaf? hiccup) (string? tier-id) (number? time)]
:post [(eaf? (first %)) (some? (second %))]}
(let [ms (str (int (* 1000 time)))
tsm (time-slot-map hiccup)
;; "ELAN assumes [...] that a single TIME_SLOT is not referenced by
;; multiple annotations if they don't depend on each other."
;; TODO: find out what happens if:
;; 1. t1 <- t2 <- t3
;; 2. a1 on t3 uses ts1 at time1
;; 3. a2 on t2 looks for a time slot at time1
;; currently, this function will make a new time slot, but maybe
;; it shouldn't
sharing-tiers (set (cons tier-id (get-parent-tiers hiccup tier-id)))
matching-id (fn [[tsid {:keys [value used-in]}]]
(and (= value ms)
(> (count (clojure.set/intersection
sharing-tiers
used-in))
0)
tsid))
matching-time-slot (some matching-id tsm)]
(if matching-time-slot
[hiccup matching-time-slot]
(let [hiccup (-> hiccup
(insert-new-time-slot ms)
reassign-time-slot-ids)]
[hiccup (some (fn [[tsid {:keys [value]}]]
(and (= value ms)
tsid))
(time-slot-map hiccup))]))))
;; annotation insertion -------------------------------------------------------
;; There's a lot that goes into this!
(defn- ref-annotation
"Constructs a new ref-annotation"
[annotation-id annotation-ref value]
[:annotation {}
[:ref-annotation
{:annotation-id annotation-id
:annotation-ref annotation-ref}
(if value
[:annotation-value {} value]
[:annotation-value {}])]])
(defn- insert-ref-annotation
[hiccup tier-id annotation-id reference-id value]
(-> hiccup
(go-to-tier tier-id)
(z/append-child (ref-annotation annotation-id reference-id value))
z/root))
(defn- alignable-annotation
"Constructs a new alignable-annotation"
[annotation-id time-slot-ref1 time-slot-ref2 value]
[:annotation {}
[:alignable-annotation
{:annotation-id annotation-id
:time-slot-ref1 time-slot-ref1
:time-slot-ref2 time-slot-ref2}
(if value
[:annotation-value {} value]
[:annotation-value {}])]])
(defn- insert-alignable-annotation
[hiccup tier-id annotation-id time-slot-ref1 time-slot-ref2 value]
(-> hiccup
(go-to-tier tier-id)
;; see above
(z/append-child (alignable-annotation annotation-id
time-slot-ref1
time-slot-ref2
value))
z/root))
(defn- time-subdivision-attrs
[hiccup tier-id start-time end-time click-time]
[hiccup {}])
(defn- included-in-attrs
[hiccup tier-id start-time end-time click-time]
[hiccup {}])
(defn- symbolic-association-attrs
[hiccup tier-id start-time end-time click-time]
[hiccup {}])
(defn- symbolic-subdivision-attrs
[hiccup tier-id start-time end-time click-time]
[hiccup {}])
(defn- no-constraint-attrs
[hiccup tier-id start-time end-time]
(let [[hiccup tsr1] (find-or-create-time-slot hiccup tier-id start-time)
[hiccup tsr2] (find-or-create-time-slot hiccup tier-id end-time)]
[hiccup {:time-slot-ref1 tsr1
:time-slot-ref2 tsr2}]))
(defn- calc-ann-attrs
"Converts raw UI data into a map containing values for any of the 3 attributes
that could appear on an annotation, viz. `:annotation-ref`, `:time-slot-ref1`,
and `:time-slot-ref2`. Returns a vector of two values: the first is the new
eaf hiccup that contains any new time slots that needed to be made, and the
second is a map containing the annotations."
[hiccup tier-id start-time end-time click-time]
(case (get-tier-constraint hiccup tier-id)
"Time_Subdivision"
(time-subdivision-attrs hiccup tier-id start-time end-time click-time)
"Included_In"
(included-in-attrs hiccup tier-id start-time end-time click-time)
"Symbolic_Association"
(symbolic-association-attrs hiccup tier-id start-time end-time click-time)
"Symbolic_Subdivision"
(symbolic-subdivision-attrs hiccup tier-id start-time end-time click-time)
;; default
(no-constraint-attrs hiccup tier-id start-time end-time)))
(defn insert-annotation
"Creates a new annotation on a tier for a given value given the raw
start and end times of the selection. Constraints are handled within
this function, ensuring that the proper time slot refs and ref ids
will be set."
[hiccup {:keys [tier-id value start-time end-time click-time]}]
;; TODO: add more preconditions
{:pre [(is (eaf? hiccup))
(is (not (nil? (get (tier-map hiccup) tier-id)))
(str "Attempted to create annotation on tier \""
tier-id "\", which does not exist"))]
:post [(eaf? %)]}
(let [ann-id (next-annotation-id hiccup)
[hiccup {:keys [time-slot-ref1
time-slot-ref2
annotation-ref]}]
(calc-ann-attrs hiccup tier-id start-time end-time click-time)]
(if (some? annotation-ref)
(insert-ref-annotation hiccup tier-id ann-id
annotation-ref
value)
(insert-alignable-annotation hiccup tier-id ann-id
time-slot-ref1 time-slot-ref2
value))))
(comment
(def *eaf (:eaf (:project/current-project re-frame.db.app-db.state)))
(insert-annotation *eaf {:tier-id "K-Spch"
:start-time 1.5
:end-time 2.5
:click-time 2.0
:value "Hello, world!"})
(swap! re-frame.db.app-db
assoc-in
[:project/current-project :eaf]
(insert-annotation *eaf {:tier-id "K-Spch"
:start-time 0.5
:end-time 3.5
:click-time 2.0
:value "Helo, world!"}))
(-> (:eaf (:project/current-project re-frame.db.app-db.state))
get-tiers
first
butlast
last)
(-> *eaf get-tiers first last)
(get-time-slot-val (:eaf (:project/current-project re-frame.db.app-db.state)) "ts18")
)
;; annotation editing ----------------------------------------------------------
(defn edit-annotation
"Replaces the inner text of the :annotation-value node for a
given annotation and returns the resulting :annotation-document"
[hiccup ann-id new-value]
(let [ann (go-to-annotation hiccup ann-id)]
(-> ann
z/down
z/down
(z/replace new-value)
z/root)))