;; -*- Mode: lisp; Syntax: ansi-common-lisp; Package: XLE; Base: 10; Readtable: augmented-readtable -*- ;;;; XLE-Web users are granted the rights to distribute and use this software ;;;; as governed by the terms of the Lisp Lesser GNU Public License ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. ;;;; Author: Paul Meurer (paul.meurer@aksis.uib.no) ;;;; Aksis, Unifob, University of Bergen, Norway ;;;; http://www.aksis.uib.no (in-package :XLE) ;; MacOS #+test (cl-user::run-shell-command "gcc -Wall -bundle -o /usr/local/xledir/lib/macos.ppc.32/xle-wrapper.dylib /home/paul/lisp/projects/xle/xle-wrapper.c -L/usr/local/xledir/lib/ -lxlecore -flat_namespace") ;; 32bit linux #+test (cl-user::run-shell-command "gcc -m32 -fPIC -Bsymbolic -shared ~/lisp/projects/xle/xle-wrapper.c -L/usr/local/xledir/lib/ -lxlecore -o /usr/local/xledir/lib/linux.x86.32/xle-wrapper.so") ;; 64bit linux #+test (cl-user::run-shell-command "gcc -m64 -fPIC -Bsymbolic -shared ~/lisp/projects/xle/xle-wrapper.c -L/usr/local/xledir/lib/linux.x86.64/ -lxlecore -o /usr/local/xledir/lib/linux.x86.64/xle-wrapper.so") ;;Edge *get_root_edge(Chart *); (progn (define-foreign-function "get_root_edge" ((chart :unsigned-long) ) :unsigned-long :lisp-name get_root_edge :module +xle-module-path+) ;; void *initialize_subtrees_traversal(struct Edge*); /* use incomplete type so */ ;; /* that we don't have to */ ;; /* define Edge. */ (define-foreign-function "initialize_subtrees_traversal" ((edge :unsigned-long) ) :unsigned-long :lisp-name initialize_subtrees_traversal :module +xle-module-path+) ;; int traverse_subtrees(void* state, Graph** mother, ;; Graph** left_daughter, Graph** right_daughter); (define-foreign-function "traverse_subtrees" ((state :unsigned-long) (mother :pointer) (left-daughter :pointer) (right-daughter :pointer) ) :int :lisp-name traverse_subtrees :module +xle-module-path+) ;; void terminate_subtrees_traversal(void* state); (define-foreign-function "terminate_subtrees_traversal" ((state :unsigned-long) ) :unsigned-long :lisp-name terminate_subtrees_traversal :module +xle-module-path+) ;; Graph *get_edge_graph(struct Edge*); /* use incomplete type */ (define-foreign-function "get_edge_graph" ((edge :unsigned-long) ) :unsigned-long :lisp-name get_edge_graph :module +xle-module-path+)) (define-foreign-function "get_next_fstructure" ((tree :unsigned-long) (fstructure :unsigned-long) (prev :int) ) :unsigned-long :lisp-name get_next_fstructure :module +xle-module-path+) (define-foreign-function "get_subtree" ((chart :unsigned-long) (edge :unsigned-long) (subtree :unsigned-long) ) :unsigned-long :lisp-name get_subtree :module +xle-module-path+) #+ignore (define-foreign-function "get_edges" ((chart :unsigned-long) ) :unsigned-long :lisp-name get_edges :module +xle-module-path+) #+ignore (define-foreign-function "print_subtree_constraints" ((subtree :unsigned-long) ) :unsigned-long :lisp-name print_subtree_constraints :module +xle-module-path+) ;; from chart-func.h ;; SExp *get_subtree_constraints(SubTree *subtree, Edge *edge); ;; /* Get the constraints associated with a subtree. */ (define-foreign-function "get_subtree_constraints" ((subtree :unsigned-long) (edge :unsigned-long) ) :unsigned-long :lisp-name get_subtree_constraints :module +xle-module-path+) ;; from instantiate-func.h ;; void print_sexp(FILE *file, SExp *sexp, ;, CVProps printprops, CVProps filterprops, ;; int depth, Graph *graph); (define-foreign-function "print_sexp" ((file :unsigned-long) (sexp :unsigned-long) (printprops :int) (filterprops :int) (depth :int) (graph :unsigned-long) ) #+allegro :void #+pcl ffc::void :lisp-name print_sexp :module +xle-module-path+) #+test (define-foreign-function "get_field" ((struct :unsigned-long) ) :unsigned-long :lisp-name get_field :module +xle-module-path+) ;; int graph_is_nogood(Graph *graph); ;; /* Graph is NULL, Bad_Graph, or nogood. */ (define-foreign-function "graph_is_nogood" ((graph :unsigned-long) ) :int :lisp-name graph_is_nogood :module +xle-module-path+) ;; from clause.h (define-foreign-variable True_Context) ;;(ff:def-foreign-variable False_Context) ;; from clause-func.h ;; char *print_clause(Clause *clause, char *buffer); ;; /* Print clause on buffer. If no buffer is given, a new one is created. */ ;; /* Calls print_clause_. */ (define-foreign-function "print_clause" ((clause :unsigned-long) (buffer :unsigned-long) ) :unsigned-long :lisp-name print_clause :module +xle-module-path+) (define-foreign-function "print_clause_" ((clause :unsigned-long) (buffer string-ptr) (size :int) ) :unsigned-long :lisp-name print_clause_ :module +xle-module-path+) ;; char *print_choice(Clause *choice, char *buffer); ;; /* Prints a choice as "a:1-3" or "b:2" */ (define-foreign-function "print_choice" ((choice :unsigned-long) (buffer string-ptr) ) :unsigned-long :lisp-name print_choice :module +xle-module-path+) (defun sexp-string (sexp printprops filterprops depth graph) ;;(print (list sexp printprops filterprops depth graph)) (if (or (zerop sexp) (zerop graph)) "-" (let ((sexp-file #+allegro(system:make-temp-file-name) #+pcl"/tmp/tmp.sexp") (created-p nil)) (unwind-protect (progn (with-open-file (stream sexp-file :direction :output :if-exists :supersede) (setf created-p t) (let ((cstream (fdopen #+allegro(excl::stream-output-handle stream) #+sbcl(common-lisp::fd-stream-fd stream) "w"))) (print_sexp cstream sexp printprops filterprops depth graph) (fflush cstream))) (with-output-to-string (stream) (with-file-lines (line sexp-file) (write-line line stream)))) (when created-p (delete-file sexp-file)))))) (defun edge-cat (edge) (let* ((vertex (foreign-slot edge Edge vertex) #+ignore(ff:fslot-value-typed 'Edge nil edge 'vertex)) (id (if (zerop vertex) 0 (foreign-slot vertex Vertex id) #+ignore(ff:fslot-value-typed 'Vertex nil vertex 'id))) (cat (if (zerop id) 0 (foreign-slot id VertexID category) #+ignore(ff:fslot-value-typed 'VertexID nil id 'category)))) #-debug(print (list :edge edge :cat cat :time (now))) (print (if (zerop cat) "cat=0" (ffc::%get-null-terminated-string cat))))) (defun dtree-cat (dtree) (unless (zerop dtree) (with-foreign-slots (edge) 'DTree dtree (edge-cat edge)))) (defun preterm-node-p (dtree) (unless (zerop dtree) (with-foreign-slots (edge) 'DTree dtree (with-foreign-slots (preterm lexical is_surface) 'Edge edge (print (list (dtree-cat dtree) preterm lexical is_surface)) (= 1 preterm))))) (defun edge-list (edgelist) (unless (zerop edgelist) (labels ((build (el) (with-foreign-slots (pEdge prune next) 'EdgeList el (cond ((zerop next) (when (zerop prune) (list pEdge))) ((zerop prune) (cons pEdge (build next))) (t (build next)))))) (build edgelist)))) (defparameter *edge* nil) #+test (let* ((count 0) (grammar (print (find-grammar "Georgian"))) (*grammar* grammar) (parser (get-parser grammar :force-p t :task :www)) (graph (parse "kargia" ;;"girls laughed girls" nil :parser parser)) (chart (parser-address parser)) (g (graph-address graph)) (root-edge (get_root_edge chart))) #-crash(print (get_next_tree 0 root-edge 0 0)) ;;(print (list :get-edges (get_edges chart))) (labels ((build (dnode) (unless (zerop dnode) (with-foreign-slots (edge subtree partial complete invalid solutions label surface surface_corr) 'DTree dnode (with-foreign-slots (id surface_corr) 'Edge edge (list* id invalid surface (mapcar #'edge-cat (edge-list surface_corr)) ;; is_surface source count graph subtrees (edge-cat edge) (unless (zerop label) (ffc::%get-null-terminated-string label)) (list* (build partial) (let ((right-tree (build complete))) (when right-tree (list right-tree)))))))))) (print (build (get_next_tree 0 root-edge 0 0))))) #+test (let* ((count 0) (grammar (print (find-grammar "Georgian" ;;"Toy" ))) (*grammar* grammar) (parser (get-parser grammar :force-p t :task :www)) (graph (parse "gadavTargmni ." ;;"girls laughed girls" nil :parser parser)) (chart (parser-address parser)) (g (graph-address graph)) (root-edge (get_root_edge chart))) #-crash(print (get_next_tree 0 root-edge 0 0)) ;;(print (list :get-edges (get_edges chart))) (labels ((build (edge) (unless (zerop edge) (with-foreign-slots (subtrees lexical source count id is_surface root nogood surface_corr graph) 'Edge edge #+old(build-f-structure-test graph) #-crash(print (get_next_tree 0 edge 0 0)) ;;(print (get_edge_graph edge)) (list* id graph nogood lexical (mapcar #'edge-cat (edge-list surface_corr)) ;; is_surface source count graph subtrees (edge-cat edge) (unless (zerop subtrees) (loop for next = (foreign-slot subtrees SubTree next) until t;(zerop next) do (setf subtrees next)) ;;(print (print_subtree_constraints subtrees)) #+test(print (get_next_fstructure subtrees 0 "next")) ;;(build-f-structure-test (get_next_fstructure subtrees 0)) (with-foreign-slots (partial complete next SExp) 'SubTree subtrees (list* next (edge-cat edge) (build partial) (let ((right-tree (build complete))) (when right-tree (list right-tree))))))))))) (setf *edge* root-edge) (build root-edge))) #+test (let* ((grammar (find-grammar "Georgian")) (parser (with-cstr (string-ptr (grammar-path grammar)) (create-parser string-ptr))) (graph (parse-sentence parser "mivsCem bavSvs Sens cigns da Xems cerils." "ROOT"))) (with-foreign-slots (compstate attrs context nogoods choice-id disjunctive nogood inconsistent local-completeness pushedfus-processed) 'Graph graph (print (list :compstate compstate :attrs attrs :context context :nogoods nogoods :choice-id choice-id :disjunctive disjunctive :nogood nogood :nogoodp (graph_is_nogood graph) :inconsistent inconsistent :local-completeness local-completeness :pushedfus-processed pushedfus-processed))) #-test (build-f-structure-test graph #+test(next-graph-solution (parse-sentence parser "mivsCem bavSvs cigns." "ROOT") 0))) (defun clause-string (clause) (%with-temporary-allocation ((string :string 400)) (ffc::%get-null-terminated-string (print_clause_ clause string 400)))) (defun build-f-structure-test (g) (unless (or (zerop g) (= g 1)) (with-foreign-slots (compstate attrs context nogoods choice-id disjunctive nogood inconsistent local-completeness) 'Graph g #-debug (print (list :compstate compstate :attrs attrs :context context :nogoods nogoods :choice-id choice-id :disjunctive disjunctive :nogood nogood :nogoodp (graph_is_nogood g) :inconsistent inconsistent :local-completeness local-completeness))) (let* (;;(compstate (foreign-slot 'Graph nil g 'compstate)) (root (find-metavariable g "UP"))) ;;(print (find-metavariable g "ROOT")) ;;(print (ffc::%get-null-terminated-string (get-attr-str root))) (Print (list :g g :root root)) (let ((id 0) (seen-pairs ())) (labels ((build (node) (unless (zerop node) (let ((var (foreign-slot node AVPair attr))) (or (getf seen-pairs var) (progn (setf (getf seen-pairs node) var) (ffc:with-foreign-slots (defined) 'AVPair node (let ((clause (%get-unsigned-long (foreign-slot defined (:array Clause 2) 0)))) (unless (zerop clause) (let ((att-string (ffc::%get-null-terminated-string (get-attr-str node)))) (unless (equal att-string "m::") (cons (list id :var var node (clause-string clause) att-string) (let ((attrs (foreign-slot node AVPair attrs)) (equals (foreign-slot node AVPair equals)) (set (get-relation-values node +REL_HAS_ELEMENT+))) #+debug(print (list :attrs attrs :set set)) (cond ((not (zerop attrs)) (if (zerop equals) (cons :attrs (build-siblings attrs)) (append (cons :attrs (build-siblings attrs)) (list* :eqq (build-values equals))))) ((not (zerop set)) ;; set value #+test (print (list :address (ff:fslot-address-typed 'CVPair nil set 'value) :value (foreign-slot 'CVPair nil set 'value) :base+offset (+ set 8))) (let* ((typed-value (foreign-slot set CVPair value)) (type (foreign-slot typed-value TypedValue type)) (value (foreign-slot typed-value TypedValue value)) (next (foreign-slot set CVPair next))) (assert (= (foreign-slot typedvalue TypedValue type) +VT_2_TUPLE+))) (cons :set (build-values set :set))) ((not (zerop equals)) (list* :eq equals (build-values equals))) (t (list :??))))))))))))))) (build-siblings (node) (unless (zerop node) (let ((av-pair (build node)) (av-pairs (build-siblings (foreign-slot node AVPair next)))) (if av-pair (cons av-pair av-pairs) av-pairs)))) (build-value (cvpair &optional setp) (let* ((contexts (foreign-slot cvpair CVPair contexts)) (context (%get-unsigned-long (foreign-slot contexts (:array Clause 2) 0))) (solutioncontext (foreign-slot cvpair CVPair solutioncontext)) (props (foreign-slot cvpair CVPair props)) (typed-value (foreign-slot cvpair CVPair value)) (type (foreign-slot typed-value TypedValue type)) (value (foreign-slot typed-value TypedValue value))) (when setp ;;(print (cons setp (set-element-type typed-value))) #+ignore (print (cons :gensym (set-element-gensym typed-value)))) (assert (zerop solutioncontext)) ;; =1 not handled yet (list* (clause-string context) (ecase props (0 "=") (1 "=c") (2 "~=") (4 "l=")) type (build-typed-value typed-value)))) (build-typed-value (typed-value) (let ((type (foreign-slot typed-value TypedValue type)) (value (foreign-slot typed-value TypedValue value))) (case type (#.+VT_STR+ ;; 1 (ffc::%get-null-terminated-string value)) (#.+VT_NUM+ ;; 2 value) (#.+VT_AVP+ ;; 3 (build value)) (#.+VT_EDGE+ ;; 4 ;; ?? ;; type :edge) (#.+VT_ATTR_ID+ ;; 5 ;; ?? (build value) #+orig value) (#.+VT_SEMFORM+ ;; 51 (build-semform typed-value)) (#.+VT_ISYM+ ;; 52 (cons :vt_isym type)) (#.+VT_GENSYM+ ;; 7 ;;(set-element-gensym value) #-test(cons :gensym (foreign-slot value Gensym next)) :gensym) (#.+VT_2_TUPLE+ ;; 103 #-ignore (cons :gensym (foreign-slot value Gensym id))) (otherwise (cons :type type)) ))) (build-values (cvpair &optional setp) (unless (zerop cvpair) (let ((value (build-value cvpair setp)) (values (build-values (foreign-slot cvpair CVPair next) setp))) (if value (cons value values) values)))) (build-semform (tv) (list :semform-id (semform_id tv) :semform (let ((semform-id (semform_id tv)) (semform-id-type (semform_id_type tv)) (semform-arg-count (semform_arg_count tv)) (semform-nonarg-count (semform_nonarg_count tv))) (ffc:%with-temporary-allocation ((arg 'TypedValue)) (collecting (semform_function tv arg) (collect (build-typed-value arg)) (collect "<") (dotimes (i semform-arg-count) (semform_arg tv (1+ i) arg) (collect (build-typed-value arg))) (collect ">") (dotimes (i semform-arg-count) (semform_nonarg tv (1+ i) arg) (collect (build-typed-value arg))) )))))) (let ((*print-level* nil)) (pprint (build root)))))))) (defparameter *inspect-fs* nil) (defun get-justifications (graph) (let ((just (get_graph_prop graph "nogoods"))) ;;(print (list :unopt (get_graph_prop graph "unoptimal"))) (collecting (labels ((get-just (just) (unless (zerop just) (with-foreign-slots (imported immutable avpair context rule ant1-type ant1-val ant2-type ant2-val next) 'Justification just (unless (zerop rule) (collect (list (ffc::%get-null-terminated-string rule) (unless (zerop avpair) (foreign-slot avpair AVPair attr))))) #+debug(print (list :just imported immutable avpair context rule ant1-type ant1-val ant2-type ant2-val next)) (get-just next))))) (get-just just))))) (defparameter *just* nil) (defparameter *equal-cvpairs-only-p* t) (defmethod build-inspect-f-structure ((graph xle-graph) &key (top-f-structure-only-p t) previous-fstructure-p next-fstructure-p &allow-other-keys) (with-slots (graph-address c-root-node active-node tree-solutions-count good-tree-solutions-count tree-solution-id) graph (with-slots (dtree) (or active-node c-root-node) ;; fix: there should always be an active node (cond (next-fstructure-p (incf tree-solution-id) (setf graph-address (get_next_fstructure dtree graph-address 0))) (previous-fstructure-p (decf tree-solution-id) (setf graph-address (get_next_fstructure dtree graph-address 1)))) (unless (or (zerop graph-address) (= graph-address 1)) (with-foreign-slots (compstate attrs context nogoods choice-id disjunctive nogood inconsistent local-completeness) 'Graph graph-address (let ((justifications (get-justifications graph-address)) (*seen-nodes* ()) (*seen-av-nodes* ()) (*seen-fs-nodes* ()) (root (find-metavariable graph-address "UP")) (id 0) (var-count 0) (vars ())) (labels ((build (avpair &optional top-p) ;; returns an # #+debug(print (list :avpair avpair)) (unless (zerop avpair) (let ((var (foreign-slot avpair AVPair attr)) (fs nil)) (labels ((build-fs (&optional (context 1)) (setf fs (or (getf *seen-fs-nodes* avpair) (setf (getf *seen-fs-nodes* avpair) (make-instance (if top-p 'top-fs 'fs) :id var :var (or (getf vars avpair) (setf (getf vars avpair) (incf var-count))) :justifications (when top-p (delete-duplicates (mapcar #'car justifications) :test #'equal)) ;;:context context )))))) (ffc:with-foreign-slots (defined) 'AVPair avpair (let ((clause (%get-unsigned-long (foreign-slot defined (:array Clause 2) 0)))) (unless (zerop clause) (let* ((att-string (ffc::%get-null-terminated-string (get-attr-str avpair))) (value (let* ((attrs (foreign-slot avpair AVPair attrs)) (equals (foreign-slot avpair AVPair equals)) (fss (build-values (get_relation_values avpair +REL_HAS_ELEMENT+) var t)) (avp (build-siblings attrs)) (cvp (build-values equals var))) (cond ((and (null avp) cvp (null (cdr cvp)) (equal (attribute (car cvp)) "=")) (value (car cvp))) (t (build-fs) (with-slots (pred av-pairs context-set fs-set) fs (setf pred (find "PRED" avp :key #'attribute :test #'string=) av-pairs (remove-if (lambda (pair) (find (attribute pair) '("PRED") :test #'string=)) avp) context-set cvp fs-set fss)) fs))))) (unless (find att-string '("m::" "SFID") :test #'equal) ;; fix this! (make-instance 'av-pair :id id :var var :attribute att-string :value value ;;:context (context-solutions graph ctx) ;; clause ;;:ctx-string (clause-string clause) ;; (format-context graph ctx) ;;:expanded-context (format-normal-form graph ctx equivalences) )))))))))) (build-siblings (avpair) (unless (zerop avpair) (let ((av-pair (build avpair)) (av-pairs (build-siblings (foreign-slot avpair AVPair next)))) (if av-pair (cons av-pair av-pairs) av-pairs)))) (build-value (cvpair var &optional setp) (let* ((contexts (foreign-slot cvpair CVPair contexts)) (context (%get-unsigned-long (foreign-slot contexts (:array Clause 2) 0))) (solutioncontext (foreign-slot cvpair CVPair solutioncontext)) (props (foreign-slot cvpair CVPair props)) (typed-value (foreign-slot cvpair CVPair value)) (justification (find var justifications :key #'cadr))) (assert (zerop solutioncontext)) (when (or (not *equal-cvpairs-only-p*) (= props 0) justification) (make-instance 'av-pair :id id :var var :attribute (ecase props (0 "=") (1 "=c") (2 "~=") (4 "l=")) :value (build-typed-value typed-value setp) :justification justification ;;:context (context-solutions graph ctx) ;; clause ;;:ctx-string (clause-string clause) ;; (format-context graph ctx) ;;:expanded-context (format-normal-form graph ctx equivalences) )))) (build-typed-value (typed-value &optional setp) (let* ((value (foreign-slot typed-value TypedValue value)) (type (if setp (set_element_type value) (foreign-slot typed-value TypedValue type))) (value (if setp (set_element_value value) value))) (case type (#.+VT_STR+ ;; 1 ;;(print (list :vt (ffc::%get-null-terminated-string value))) (ffc::%get-null-terminated-string value)) (#.+VT_NUM+ ;; 2 value);;(ffc::%get-null-terminated-string value) (#.+VT_AVP+ ;; 3 (build value)) (#.+VT_EDGE+ ;; 4 ;; ?? value) (#.+VT_ATTR_ID+ ;; 5 ;; pointer (build value) (getf *seen-fs-nodes* value)) (#.+VT_SEMFORM+ ;; 51 (build-semform typed-value)) (#.+VT_ISYM+ ;; 52 ;;(Print :isym) ;; ?? "-ISYM-" ;;(print (ffc::%get-null-terminated-string (print value))) ) (#.+VT_GENSYM+ ;; 7 ;;(set-element-gensym value) #-test(cons :gensym (foreign-slot value Gensym next)) :gensym) (#.+VT_2_TUPLE+ ;; 103 #-ignore (cons :gensym (foreign-slot value Gensym id))) (otherwise (cons :type type)) ))) (build-values (cvpair var &optional setp) (unless (zerop cvpair) (let ((value (build-value cvpair var setp)) (values (build-values (foreign-slot cvpair CVPair next) var setp))) (if value (cons (if setp (cons (cons 1 "1") (value value)) value) values) values)))) (build-semform (tv) (ffc:%with-temporary-allocation ((arg 'TypedValue)) (let* ((semform-id (semform_id tv)) (semform-id-type (semform_id_type tv)) (semform-arg-count (semform_arg_count tv)) (semform-nonarg-count (semform_nonarg_count tv)) (function (progn (semform_function tv arg) (build-typed-value arg))) (semform (make-instance 'semform :id (incf id) :lemma function :sem-var semform-id ;;:context (context-solutions graph ctx) ;;:ctx-string (format-context graph ctx) ;;:expanded-context (format-normal-form graph ctx equivalences) ))) (with-slots (subcat-frame athematic-frame) semform (setf subcat-frame (collecting (dotimes (i semform-arg-count) (semform_arg tv (1+ i) arg) (collect (build-typed-value arg)))) athematic-frame (collecting (dotimes (i semform-nonarg-count) (semform_nonarg tv (1+ i) arg) (collect (build-typed-value arg)))))) semform)))) (let ((*print-level* nil)) (prog1 (setf *inspect-fs* (value (build root t))) #+ignore (dolist (just justifications) (destructuring-bind (rule avpair) just (unless (zerop avpair) (print (setf *just* (build avpair)))))) #+ignore(print *seen-fs-nodes*))) ))))))) (defparameter *node* nil) (defclass inspect-node-mixin () ((edge :initform 0 :initarg :edge :accessor edge) (dtree :initform 0 :initarg :dtree :accessor dtree) (partialp :initform nil :initarg :partialp :accessor partialp) (subtrees :initform nil :initarg :subtrees :accessor subtrees) (sublexicalp :initform nil :initarg :sublexicalp :accessor sublexicalp) (preterminalp :initform nil :initarg :preterminalp :accessor preterminalp) (has-fstructure-p :initform nil :initarg :has-fstructure-p :reader has-fstructure-p) (first-subtree-p :initform nil :initarg :first-subtree-p :accessor first-subtree-p) (last-subtree-p :initform nil :initarg :last-subtree-p :accessor last-subtree-p) (subtree-count :initform nil :initarg :subtree-count :accessor subtree-count) (sexp :initform nil :initarg :sexp :accessor sexp))) (defclass c-inspect-node (inspect-node-mixin c-node) ()) (defclass c-inspect-surface-node (inspect-node-mixin c-surface-node) ()) (defmethod graph::write-node-svg-text ((node c-inspect-node) &key left bottom width stream &allow-other-keys) (with-slots (projection-fs-ids graph::graph graph::value) node (let* ((x-center (graph::node-x-center node (graph::graph-layout-style graph::graph))) (match-pos nil) (submatch nil) (base-class (string-downcase (symbol-name (node-type node)))) (text-x (- x-center (* (length (node-label node)) 4))) ;; workaround for WebKit SVG bug (var (when match-pos (aref *variable-names* match-pos))) (var (unless (eq (search "my" var) 0) var))) #m(rect/ :class "text-box" :x #s (if *middle-anchor-p* x-center text-x) :y #s (- bottom 4 14) :height 18 :width #s (+ width 0)) #m((text :class #s base-class :id #s(when (node-children node) (format nil "fs~{~d~^:~}" projection-fs-ids)) :node-id #s(cdr graph::value) :base-class #s base-class :text-anchor #s(when *middle-anchor-p* "middle") :text-decoration #s(if (has-fstructure-p node) "underline") :opacity #s(if (has-fstructure-p node) "1.0" "0.5") :onmouseover #s(cond ((and projection-fs-ids (node-children node)) (format nil (concat "hiliteProjectingNodes(evt.target, true); " "~{ var fs = window.parent.document.getElementById(~d); fs.className = 'fs-projection';~}") projection-fs-ids (sexp node))) ((sexp node) (format nil (concat "var sexp = window.parent.document.getElementById('sexp'); sexp.innerHTML = \"~a\"") (sexp node)))) :onmouseout #s(cond ((and projection-fs-ids (node-children node)) ;; projection-fs-ids (format nil (concat "hiliteProjectingNodes(evt.target, false); " "~{ var fs = window.parent.document.getElementById(~d); fs.className = 'fs';~}") projection-fs-ids)) ((sexp node) "var sexp = window.parent.document.getElementById('sexp'); sexp.innerHTML = ''")) :onclick #s(format nil (concat "var id = window.parent.document.getElementById('node-id'); " "id.value = ~d; " "var form = window.parent.document.getElementById('form'); form.submit()") (cdr graph::value)) :x #s(if *middle-anchor-p* x-center text-x) :y #s(- bottom 4)) #s(node-label node) #s(if (has-fstructure-p node) "" "*") #L(when (and *show-projection-ids-p* (node-children node) (not var)) #m((tspan :dy "3" :fill "red" :font-size "8px" :font-style "normal") #s (format nil "~{~d~^:~}" projection-fs-ids))) #L(when var #m((tspan :dy "3" :fill "magenta" :font-size "10px" :font-style "normal") #s (if (cdr *submatches*) (format nil "~a.~d" var (1+ submatch)) var)))) (when (or (not (first-subtree-p node)) (not (last-subtree-p node))) (unless (first-subtree-p node) #m(path/ :r "8" :fill "red" :stroke "red" :class "triangle" :fill-opacity "0.3" :d #s(format nil "M ~d,~d l-12,4 12,4 z" (- x-center 14) (+ bottom 1)) :onclick #s(format nil (concat "var id = window.parent.document.getElementById('node-id'); " "var dtree = window.parent.document.getElementById('dtree'); " "id.value = ~d; " "dtree.value = 'previous'; " "var form = window.parent.document.getElementById('form'); form.submit()") (cdr graph::value)))) #m((text :text-anchor #s(when *middle-anchor-p* "middle") :class "count" :x #s(if *middle-anchor-p* x-center (- x-center 10)) :y #s(+ bottom 8)) #s(subtree-count node)) (unless (last-subtree-p node) #m(path/ :r "8" :fill "red" :stroke "red" :class "triangle" :fill-opacity "0.3" :d #s(format nil "M ~d,~d l12,4 -12,4 z" (+ x-center 14) (+ bottom 1)) :onclick #s(format nil (concat "var id = window.parent.document.getElementById('node-id'); " "var dtree = window.parent.document.getElementById('dtree'); " "id.value = ~d; " "dtree.value = 'next'; " "var form = window.parent.document.getElementById('form'); form.submit()") (cdr graph::value))))) #+test (when (sexp node) #m((text :text-anchor "middle" :class "sexp" :x #L(write-to-string x-center) :y #L(write-to-string (+ bottom 10))) #s(print (sexp node)))) ))) (defmethod node-children ((node c-inspect-node)) (with-slots (children) node (let ((complete (if (cdr children) (cadr children) (car children)))) (cond ((and (not *sublexical-nodes-p*) complete (or (sublexicalp complete) (preterminalp complete))) #+debug(print (list :node node :complete complete :children (node-children complete))) (node-children complete)) (*partial-nodes-p* children) (t (labels ((build (node right-children) (with-slots (children) node (cond ((cdr children) (build (car children) (cons (cadr children) right-children))) ((car children) (cons (car children) right-children)) (t right-children))))) (build node ()))))))) #+old (defmethod node-children ((node c-inspect-node)) (if *partial-nodes-p* (slot-value node 'children) (labels ((build (node right-children) (with-slots (children) node (cond ((cdr children) (build (car children) (cons (cadr children) right-children))) ((car children) (cons (car children) right-children)) (t right-children))))) (build node ())))) #+test (defun count-subtrees (subtree) (let ((count 1)) (labels ((count (subtree) (with-foreign-slots (next) 'SubTree subtree (unless (zerop next) (incf count) (count next))))) (count subtree) count))) (defun count-subtrees (subtree &optional (count 1)) (with-foreign-slots (next) 'SubTree subtree (if (zerop next) count (count-subtrees next (1+ count))))) (defparameter *show-sexp* nil) (defvar *morph-parents*) (defvar *surface-forms*) ;; void apply_to_edges(Chart *, void (*)(Edge *)); (define-foreign-function "apply_to_edges" ((chart :unsigned-long) (fun :unsigned-long) ) #+allegro :void #+sbcl ffc::void :lisp-name apply_to_edges :module +xle-module-path+) ;; void apply_to_edges1(Chart *, void (*)(Edge *, void *), void *); ;; void apply_to_edges2(Chart *, void (*)(Edge *, void *, void *) void *, void *); (defvar %edge-function%) (ff::defun-foreign-callable map-edge-callback (edge) (funcall %edge-function% edge)) (defparameter *map-edge-ptr* (print (ff:register-foreign-callable 'map-edge-callback))) (defun map-edges (chart fun) (let ((%edge-function% fun)) (apply_to_edges chart *map-edge-ptr*))) (defmethod edge-chart ((xle-graph xle-graph) edge &key morph-only-p) ;; foreach edge [get_edges $chartData] { (with-foreign-slots (subtrees lexical preterm surface_corr) 'Edge edge (unless (and morph-only-p (and (zerop lexical) (zerop preterm))) (cond ((if morph-only-p (not (zerop surface_corr)) (zerop lexical)) (labels ((walk (edge-list) (unless (zerop edge-list) (with-foreign-slots (pEdge next) 'EdgeList edge-list (pushnew pEdge *surface-forms*) (pushnew edge (getf *morph-parents* pEdge)) (walk next))))) (walk surface_corr))) ((not (zerop lexical)) (pushnew edge *surface-forms*))) (labels ((walk (subtree) #+debug(print (list :subtree subtree)) (unless (zerop subtree) (with-foreign-slots (next complete) 'SubTree subtree ;;(print *morph-parents*) (pushnew edge (getf *morph-parents* complete)) (walk next))))) (walk subtrees))))) (defun edge-status (edge) (let ((status "") (unknown-status "")) (with-foreign-slots (graph subtrees surface_corr unknown lexentry_found) 'Edge edge #+debug(print (list graph subtrees surface_corr unknown lexentry_found)) ;; edge_graph = edge->graph; (cond ((and (zerop (graph-p graph)) (not (zerop subtrees))) (setf status "*")) ;;if (!graph_p(edge_graph) && edge->subtrees) status = "*"; ((and (not (zerop (graph-p graph))) (not (zerop (foreign-slot graph Graph solution-sets))) (zerop (foreign-slot (foreign-slot graph Graph solution-sets) RestrictionSet solutions))) (setf status "#")) ;;else if (graph_p(edge_graph) && ;; edge_graph->solution_sets != NULL && ;; edge_graph->solution_sets->solutions == NULL) status = "#"; (t nil)) ;; else status = ""; ;; unknown = ""; ;; if (edge->unknown && edge->surface_corr && !edge->lexentry_found) { ;; unknown = "??"; ;; } (when (and (not (zerop unknown)) (not (zerop surface_corr)) (zerop lexentry_found)) (setf unknown-status "??")) (when (and (not (zerop unknown)) (not (zerop surface_corr)) (zerop lexentry_found)) (setf unknown-status "?")) ;; if (edge->unknown && edge->preterm) { ;; unknown = "?"; ;; } (concat unknown-status status)))) (defmethod build-chart-tree ((xle-graph xle-graph) &key morph-parents surface-forms morph-only-p) (let ((*morph-parents* morph-parents) (*surface-forms* surface-forms)) (unless surface-forms (map-edges (parser-address (parser xle-graph)) (lambda (edge) (edge-chart xle-graph edge :morph-only-p morph-only-p)))) (labels ((walk (edge) (let* ((vertex (foreign-slot edge Edge vertex)) (edge-id (foreign-slot edge Edge id)) (right_vertex (foreign-slot edge Edge right_vertex)) (nogood (foreign-slot edge Edge nogood)) (id (foreign-slot vertex Vertex id))) (cons (list edge edge-id (ffc::%get-null-terminated-string (foreign-slot id VertexID category)) (edge-status edge) (foreign-slot id VertexID index) right_vertex) (collecting (dolist (child-edge (getf *morph-parents* edge)) (unless (= edge child-edge) (collect (walk child-edge))))))))) (mapcar #'walk *surface-forms*)))) (defun now () (net.aserve::universal-time-to-apache-log-date (get-universal-time))) (defmethod build-inspect-c-structure ((xle-graph xle-graph) &key #+old(ignore-base-p t) edge node-id next-p previous-p (build-morphology-tree-p t) build-chart-tree-p &allow-other-keys) #-debug(print (list :node-id node-id next-p previous-p :build-chart-tree-p build-chart-tree-p )) (when (and (or build-morphology-tree-p build-chart-tree-p) #+ignore(or (null node-id) next-p previous-p)) (setf (morphology-tree xle-graph) (build-chart-tree xle-graph :morph-only-p (not build-chart-tree-p))) #+debug(print (list :morphology-tree (morphology-tree xle-graph)))) (let ((*morph-parents* ()) (*surface-forms* ())) (labels ((build-node (dnode &key partialp next-subtree previous-subtree) #-debug(print (list :dnode dnode :time (now))) (unless (zerop dnode) (let ((has-next-p nil) (has-prev-p nil) (subtree-pos nil) (subtree-count nil) (sexp-string nil)) (with-foreign-slots (edge subtree partial complete invalid solutions label surface surface_corr) 'DTree dnode (with-foreign-slots (subtrees id lexical source count is_surface preterm chart next root nogood surface_corr graph vertex right_vertex) 'Edge edge (edge-chart xle-graph edge :morph-only-p (not build-chart-tree-p)) ;;(print (list :get-edges (get_edges chart))) #-debug(print (list :vertex vertex :right_vertex right_vertex :subtree subtree :time (now))) #+debug (let* ((id (if (zerop vertex) 0 (foreign-slot vertex Vertex id))) (cat (if (zerop id) 0 (foreign-slot id VertexID category)))) (print (list ;;:id id :lexical lexical :is_surface is_surface :preterm preterm :surface_corr surface_corr :type (foreign-slot id VertexID type) :cat (if (zerop cat) "xxx" (ffc::%get-null-terminated-string cat)) ;;:vertex vertex :index (foreign-slot id VertexID index) :right_vertex right_vertex))) (unless (zerop subtree) (setf has-prev-p (not (= subtree subtrees)) subtree-count (count-subtrees subtrees) subtree-pos (- subtree-count (count-subtrees subtree) -1)) (with-foreign-slots (next) 'SubTree subtree (setf has-next-p (not (zerop next))))) #-disabled2007 (unless (zerop subtrees) #-debug(print (list :next-fstructure (now))) (let ((g (get_next_fstructure dnode 0 0)) (sexp (when *show-sexp* (get_subtree_constraints subtrees edge)))) #-debug(print (list :next-fstructure-fetched (now))) (unless (or (zerop g) (null sexp) (zerop sexp)) (setf sexp-string (dat::subst-substrings (utf-8-encode (sexp-string sexp 0 0 0 g)) (list "\"" """ (string #\linefeed) "")))))) #+debug(print (list :dnode dnode (get_next_tree dnode edge 0 0) (count_trees edge 1) count partial complete surface (edge-cat edge) label :time (now))) (let* ((label (substitute #\' #\" (edge-cat edge))) ;;(id (tree_id dnode)) (surface-edges (edge-list surface_corr)) (node (cond ((not (zerop complete)) (let ((child-cat (dtree-cat complete)) (child (build-node complete))) ;; if IGNORE-BASE-P is true ignore nodes labelled _BASE, ;; i.e. make their children children of the base node's parent (make-instance 'c-inspect-node :value (cons label id) :xle-graph xle-graph :type :data :label (format nil "~a~a:~d" (if partialp "/" "") label id) :partialp partialp :edge edge :has-fstructure-p t #+disabled2007 (not (zerop (get_next_fstructure dnode 0 0))) :last-subtree-p (not has-next-p) :first-subtree-p (not has-prev-p) :subtree-count (format nil "~d/~d" subtree-pos subtree-count) :sexp sexp-string :sublexicalp (search "_BASE" label :test #'equal) :dtree dnode ;;:subtrees subtrees :children (let ((left (build-node partial :partialp t))) (if left (list left child) (list child)))))) ((null surface-edges) nil) (t (make-instance 'c-inspect-node :value (cons label id) :xle-graph xle-graph :last-subtree-p (not has-next-p) :first-subtree-p (not has-prev-p) :sexp sexp-string :subtree-count subtree-count :preterminalp t :label label :children (list (build-surface-form surface-edges))))))) #+debug(print (list node :has-prev-p has-prev-p :has-next-p has-next-p :subtree-count subtree-count :count count)) node)))))) ;; the surface form gets special treatment (build-surface-form (edges &optional bracket-label) #+orig(assert (null (cdr edges))) #-debug(print (list :edges edges)) (let ((labels (mapcar #'edge-cat edges))) (make-instance 'c-inspect-surface-node :value (cons (car labels) (car edges)) :xle-graph xle-graph :surface-string labels :type :surface-form :edge (car edges) :morphology (cond ((null bracket-label) nil) ((char= (char bracket-label 0) #\+) bracket-label) (t ;;(format nil "~d:~a" id bracket-label) bracket-label)) :label (format nil "~{~a~^|~}" labels)))) (find-id-node (node id parent) ;; find node with given id (when (and node id) (if (eq (cdr (node-value node)) id) (progn (setf (node-type node) :data-active) (when (active-node xle-graph) (setf (node-type (active-node xle-graph)) :data)) (setf (active-node xle-graph) node) (list node parent)) (with-slots (children) node (or (find-id-node (car children) id node) (find-id-node (cadr children) id node))))))) ;; start with root node (let* ((parser (parser xle-graph)) (chart (print (parser-address parser))) (g (print (graph-address xle-graph))) (root-edge (print (get_root_edge chart))) (root-graph (unless (zerop root-edge) (foreign-slot root-edge Edge graph))) (active-dtree nil)) ;;(build-f-structure-test root-graph) (destructuring-bind (&optional node parent) (unless edge (find-id-node (c-root-node xle-graph) node-id :root)) #+debug(print (list :node node :parent parent :edge edge)) (multiple-value-prog1 (cond (node (if (or previous-p next-p) (if t ;;(eq parent :root) (let ((new-tree (get_next_subtree (dtree node) (edge node) (if previous-p 1 0)))) #-debug(print (list :new-tree new-tree)) (setf active-dtree new-tree) (let* ((new-root-node (build-node new-tree :next-subtree t)) (new-node (when new-root-node (car (find-id-node new-root-node node-id :root)))) (g (when new-node (get_next_fstructure (dtree new-node) 0 0)))) (values g (if (zerop new-tree) (c-root-node xle-graph) new-root-node)))) (with-slots (children) parent (let* ((dtree (get_next_tree (dtr