...
 
Commits (2)
; DO NOT EDIT (unless you know what you are doing)
;
; This subdirectory is a git "subrepo", and this file is maintained by the
; git-subrepo command. See https://github.com/git-commands/git-subrepo#readme
;
[subrepo]
remote = https://gitlab.ai.vub.ac.be/rvantrijp/category-hierarchies.git
branch = master
commit = aedefd25b891adf79cf6f07c3bc1c3664a6c577d
parent = c1318cc5b99863d52227e9890c00f3d1338bc514
method = merge
cmdver = 0.4.0
;; Copyright 2019 AI Lab, Vrije Universiteit Brussel - Sony CSL Paris
;; Licensed under the Apache License, Version 2.0 (the "License");
;; you may not use this file except in compliance with the License.
;; You may obtain a copy of the License at
;; http://www.apache.org/licenses/LICENSE-2.0
;; Unless required by applicable law or agreed to in writing, software
;; distributed under the License is distributed on an "AS IS" BASIS,
;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
;; See the License for the specific language governing permissions and
;; limitations under the License.
;;=========================================================================
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Additions to graph-utils ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(in-package :graph-utils)
(export '(set-edge-weight find-cheapest-path find-weight-of-path))
(defmethod set-edge-weight ((graph graph) n1 n2 weight &key &allow-other-keys)
(set-edge-weight graph (gethash n1 (graph-utils::nodes graph)) (gethash n2 (graph-utils::nodes graph)) weight))
(defmethod find-cheapest-path ((graph graph) (n1 integer) (n2 integer))
"Dijkstra's algorithm for finding the shortest path between two nodes."
(let ((nodes (node-ids graph)))
(let ((distances (mapcar (lambda (n) (cons n most-positive-fixnum)) nodes))
(previous (mapcar (lambda (n) (cons n nil)) nodes)))
(setf (cdr (assoc n1 distances)) 0)
(loop until (null nodes) do
(setf distances (sort distances '< :key 'cdr))
(let ((next (first (remove-if-not (lambda (d)
(member (car d) nodes))
distances))))
(when (= (cdr next) most-positive-fixnum)
(return nil))
(when (= (car next) n2)
(return-from find-cheapest-path
(nreverse (reconstruct-path previous n2))))
(setq nodes (remove (car next) nodes))
(dolist (neighbor (if (directed? graph)
(outbound-neighbors graph (car next))
(neighbors graph (car next))))
(let ((distance (+ (cdr (assoc (car next) distances)) (edge-weight graph (car next) neighbor))))
(when (< distance (cdr (assoc neighbor distances)))
(setf (cdr (assoc neighbor distances)) distance
(cdr (assoc neighbor previous)) (car next))))))))))
(defmethod find-cheapest-path ((graph graph) n1 n2)
(find-cheapest-path graph
(gethash n1 (nodes graph))
(gethash n2 (nodes graph))))
(defmethod find-weight-of-path ((graph graph) path)
"Returns the total weight of a path."
(loop for (n1 n2) in path summing (edge-weight graph n1 n2)))
(export '(visualize-type-hierarchy))
(defmethod visualize-type-hierarchy ((graph graph) &key (file "/var/tmp/graph.dot") render? weights?
colors sizes (format "svg") colored-edges-0-1)
"Save a dot file of this graph. Render can be one of (:heirarchical
:circular :radial :spring), which will render the graph using the appropriate
Graphviz tool."
(let ((memory (make-hash-table :test 'equalp))
(connector (if (directed? graph) "->" "--")))
(with-open-file (out file
:direction :output
:if-exists :supersede
:if-does-not-exist :create)
(format out
"~A graphutils~%{~% splines=true;~% node [ color = black, "
(if (directed? graph) "digraph" "graph"))
(format out "fillcolor = white, style = filled, fontsize=10, fontname = times];~%")
(map-nodes (lambda (name id)
(let ((neighbors (if (directed? graph)
(outbound-neighbors graph id)
(neighbors graph id))))
(dolist (n neighbors)
(unless (if (directed? graph)
(gethash (list id n) memory)
(or (gethash (list id n) memory)
(gethash (list n id) memory)))
(setf (gethash (list id n) memory) t)
(when (not (directed? graph))
(setf (gethash (list n id) memory) t))
(if weights?
(format out
" \"~A\" ~A \"~A\" [w=~,2f,label=~,2f,fontsize=10, ~a, ~a, ~a];~%"
name
connector
(gethash n (ids graph))
(saref (matrix graph) id n)
(saref (matrix graph) id n)
(if (and colored-edges-0-1
(<= (saref (matrix graph) id n) 1.0)
(>= (saref (matrix graph) id n) 0.0))
(format nil "fontcolor=grey~a" (min (round (* 100 (saref (matrix graph) id n))) 80))
(format nil "fontcolor=black"))
(if (and colored-edges-0-1
(<= (saref (matrix graph) id n) 1.0)
(>= (saref (matrix graph) id n) 0.0))
(format nil "color=grey~a" (min (round (* 100 (saref (matrix graph) id n))) 80))
(format nil "color=black"))
(if colored-edges-0-1
(cond ((and (< (saref (matrix graph) id n) 0.1)
(>= (saref (matrix graph) id n) 0.0))
(format nil "style=bold"))
((and (<= (saref (matrix graph) id n) 1)
(> (saref (matrix graph) id n) 0.9))
(format nil "style=dotted"))
(t
(format nil "style=filled")))))
(format out
" \"~A\" ~A \"~A\" [w=~,2f];~%"
name
connector
(gethash n (ids graph))
(saref (matrix graph) id n)))))
(format out " \"~A\" [fillcolor=\"~A\""
name
(if (hash-table-p colors)
(gethash name colors)
"#ffff00"))
(if (hash-table-p sizes)
(progn
(format out ",shape=box,width=~F,fontname=Helvetica,"
(gethash name sizes))
(format out "fixedsize=true,fontsize=~D"
(truncate (* 10 (gethash name sizes)))))
"")
(format out "];~%")))
graph)
(format out "}~%"))
(if render?
(let ((f (regex-replace "\.[a-z]+$" file (format nil "\.~A" format)))
(program (case render?
(:hierarchical (which "dot"))
(:circular (which "circo"))
(:radial (which "twopi"))
(:spring (or (which "fdp") (which "neato")))
(otherwise (or (which "fdp") (which "dot"))))))
(if program
(multiple-value-bind (output error-output exit-status)
(trivial-shell:shell-command
(format nil "~A -T~A -o ~A ~A" program format f file))
(unless (= 0 exit-status)
(error "~A exited with status ~A: ~A ~A~%" program exit-status output error-output)))
(format t "Unable to create PNG of graph ~A. Graphviz not in your path.~%" graph))
f)
file)))
;; Copyright 2019 AI Lab, Vrije Universiteit Brussel - Sony CSL Paris
;; Licensed under the Apache License, Version 2.0 (the "License");
;; you may not use this file except in compliance with the License.
;; You may obtain a copy of the License at
;; http://www.apache.org/licenses/LICENSE-2.0
;; Unless required by applicable law or agreed to in writing, software
;; distributed under the License is distributed on an "AS IS" BASIS,
;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
;; See the License for the specific language governing permissions and
;; limitations under the License.
;;=========================================================================
(in-package :type-hierarchies)
(export '(type-hierarchy->image))
(defun type-hierarchy->image (type-hierarchy &key (render-program "dot") weights? colored-edges-0-1 path file-name format (open nil))
"makes an image from a type hierarchy"
;; Let's specify a paths and filenames ;;
(let* ((path (or path wi::*graphviz-output-directory*))
(format (or format "png"))
(file-name (or file-name (downcase (gensym "TYPE-HIERARCHY-"))))
(dot-file (merge-pathnames path (make-pathname :name file-name
:type "dot")))
(image-file (merge-pathnames path (make-pathname :name file-name
:type format))))
(ensure-directories-exist path)
;; Let's make the dot file ;;
(visualize-type-hierarchy (graph type-hierarchy) :file dot-file :weights? weights? :colored-edges-0-1 colored-edges-0-1)
;; Let's make the image file ;;
(run-prog render-program :args (list (mkstr "-T" format)
(format nil "~a" dot-file)
(mkstr "-o" (format nil "~a" image-file)))
:wait t)
;; Let's open it! ;;
;; although we run dot with :wait t, on some machines it might
;; happen that the resulting image is not accessible yet, so we
;; wait. Although we also don't wait for more than 5 seconds
;; because the file might, for some erroneous reason, never be
;; written (e.g. dot is not found on the system).
(loop for i from 1 to 100
until (probe-file image-file)
do (sleep 0.05))
;; try to open it
(when open
(cond
((equal (software-type) "Darwin")
(run-prog "open" :args (list (format nil "~a" image-file))))
((equal (software-type) "Linux")
(run-prog "see" :args (list (format nil "~a" image-file))))
((equal (software-type) "Microsoft Windows")
(run-prog "cmd"
:args (list "/C"
(string-replace
(format nil "\"c:~a\"" image-file) "/" "\\"))))))
image-file))
(defmethod make-html ((type-hierarchy type-hierarchy) &key (weights? nil) (colored-edges-0-1 t) (render-program "dot") &allow-other-keys)
"generates html code for a type-hierarchy"
(let* ((path (type-hierarchy->image type-hierarchy :open nil :format "svg" :weights? weights? :colored-edges-0-1 colored-edges-0-1 :render-program render-program))
(svg (with-open-file (stream path :direction :input)
(let ((lines nil) (line nil))
(loop do (setf line (read-line stream nil))
;; skip stuff before <svg ...
until (and (> (length line) 3) (equal (subseq line 0 4) "<svg")))
(loop ;; skip comments
do (unless (and (> (length line) 3) (equal (subseq line 0 4) "<!--"))
(push line lines))
(setf line (if (equal line "</svg>")
nil
(read-line stream nil)))
while line)
(close stream)
(reduce #'string-append (reverse lines))))))
`((div) ,svg)))
;; Copyright 2019 AI Lab, Vrije Universiteit Brussel - Sony CSL Paris
;; Licensed under the Apache License, Version 2.0 (the "License");
;; you may not use this file except in compliance with the License.
;; You may obtain a copy of the License at
;; http://www.apache.org/licenses/LICENSE-2.0
;; Unless required by applicable law or agreed to in writing, software
;; distributed under the License is distributed on an "AS IS" BASIS,
;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
;; See the License for the specific language governing permissions and
;; limitations under the License.
;;=========================================================================
(in-package :common-lisp-user)
(defpackage :type-hierarchies
(:use :common-lisp :monitors :utils :test-framework :fcg :s-dot :graph-utils
#+:hunchentoot-available-on-this-platform :web-interface)
(:shadow "UNIFY" "WEIGHT" "ADD-NODE" "LEAF?")
(:documentation "Package for type hierarchy support in FCG")
(:import-from :cl-user))
(pushnew :type-hierarchies *features*)
\ No newline at end of file
;; Copyright 2019 AI Lab, Vrije Universiteit Brussel - Sony CSL Paris
;; Licensed under the Apache License, Version 2.0 (the "License");
;; you may not use this file except in compliance with the License.
;; You may obtain a copy of the License at
;; http://www.apache.org/licenses/LICENSE-2.0
;; Unless required by applicable law or agreed to in writing, software
;; distributed under the License is distributed on an "AS IS" BASIS,
;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
;; See the License for the specific language governing permissions and
;; limitations under the License.
;;=========================================================================
(in-package :type-hierarchies)
(deftest test-type-hierarchies-classes-and-methods ()
(let ((type-hierarchy (make-instance 'type-hierarchy)))
(test-assert (add-categories '(gender m f n) type-hierarchy))
(test-assert (add-link 'm 'gender type-hierarchy))
(add-link 'f 'gender type-hierarchy)
(add-link 'n 'gender type-hierarchy)
(test-assert (add-category 'number type-hierarchy))
(add-category 'sg type-hierarchy)
(add-category 'pl type-hierarchy)
(add-link 'sg 'number type-hierarchy)
(add-link 'pl 'number type-hierarchy)
(add-categories '(noun common-noun proper-noun count-noun mass-noun) type-hierarchy)
(add-link 'common-noun 'noun type-hierarchy)
(add-link 'proper-noun 'noun type-hierarchy)
(add-link 'count-noun 'common-noun type-hierarchy)
(add-link 'mass-noun 'common-noun type-hierarchy)
(test-assert (eq t (node-p 'gender type-hierarchy)))
(test-assert (eq t (connected-p 'gender 'm type-hierarchy)))
(test-assert (eq t (connected-p 'm 'gender type-hierarchy)))
(test-assert (eq nil (connected-p 'm 'number type-hierarchy)))
(test-assert (eq t (connected-p 'mass-noun 'noun type-hierarchy)))
(test-assert (eq t (connected-p 'noun 'mass-noun type-hierarchy)))
(test-assert (eq t (connected-p 'proper-noun 'mass-noun type-hierarchy)))
(test-assert (eq t (connected-p 'proper-noun 'mass-noun type-hierarchy)))
(test-assert (eq t (directed-path-p 'mass-noun 'noun type-hierarchy)))
(test-assert (eq nil (directed-path-p 'noun 'mass-noun type-hierarchy)))
(test-assert (eq nil (directed-path-p 'mass-noun 'proper-noun type-hierarchy)))
(test-assert (eq nil (directed-path-p 'proper-noun 'mass-noun type-hierarchy)))
(test-assert (eq nil (directed-distance 'noun 'mass-noun type-hierarchy)))
(test-assert (eq 2 (directed-distance 'mass-noun 'noun type-hierarchy)))
(test-assert (eq 1 (directed-distance 'common-noun 'noun type-hierarchy)))
(test-assert (eq nil (directed-distance 'noun 'common-noun type-hierarchy)))
(test-assert (eq nil (directed-distance 'noun 'gender type-hierarchy)))
(test-assert (eq nil (directed-distance 'common-noun 'proper-noun type-hierarchy)))
(test-assert (eq nil (directed-distance 'mass-noun 'count-noun type-hierarchy)))
(test-assert (eq 2 (undirected-distance 'noun 'mass-noun type-hierarchy)))
(test-assert (eq 2 (undirected-distance 'mass-noun 'noun type-hierarchy)))
(test-assert (eq 1 (undirected-distance 'common-noun 'noun type-hierarchy)))
(test-assert (eq 1 (undirected-distance 'noun 'common-noun type-hierarchy)))
(test-assert (eq nil (undirected-distance 'noun 'gender type-hierarchy)))
(test-assert (eq 2 (undirected-distance 'common-noun 'proper-noun type-hierarchy)))
(test-assert (eq 2 (undirected-distance 'mass-noun 'count-noun type-hierarchy)))))
;; (test-type-hierarchies-classes-and-methods)
\ No newline at end of file
;; Copyright 2019 AI Lab, Vrije Universiteit Brussel - Sony CSL Paris
;; Licensed under the Apache License, Version 2.0 (the "License");
;; you may not use this file except in compliance with the License.
;; You may obtain a copy of the License at
;; http://www.apache.org/licenses/LICENSE-2.0
;; Unless required by applicable law or agreed to in writing, software
;; distributed under the License is distributed on an "AS IS" BASIS,
;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
;; See the License for the specific language governing permissions and
;; limitations under the License.
;;=========================================================================
(in-package :asdf)
(defsystem :type-hierarchies
:description "General support for using type-hierarchies in
FCG."
:depends-on (:fcg :graph-utils)
:components
((:file "package")
(:file "graph-utils-additions")
(:file "type-hierarchy")
(:file "type-hierarchy-matcher")
(:file "html")))
;; Copyright 2019 AI Lab, Vrije Universiteit Brussel - Sony CSL Paris
;; Licensed under the Apache License, Version 2.0 (the "License");
;; you may not use this file except in compliance with the License.
;; You may obtain a copy of the License at
;; http://www.apache.org/licenses/LICENSE-2.0
;; Unless required by applicable law or agreed to in writing, software
;; distributed under the License is distributed on an "AS IS" BASIS,
;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
;; See the License for the specific language governing permissions and
;; limitations under the License.
;;=========================================================================
(in-package :fcg)
;; If it turns out that people use the type-hierarchies,
;; this function should become the standard one in systems/fcg
(defun unify-atom (x y bindings &key cxn-inventory)
"unify-atom function for use with type-hierarchies"
(cond ((eq bindings +fail+) +fail+)
;; handle strings and interned symbols
((equal x y) bindings)
;; unify uninterned symbols
((and (symbolp x) (symbolp y)
(equal (symbol-name x) (symbol-name y)) bindings))
;; unify symbols on type-hierarchy-basis
((and cxn-inventory
(type-hierarchies::get-type-hierarchy cxn-inventory)
(symbolp x) (symbolp y)
(type-hierarchies::node-p (intern (symbol-name x) :type-hierarchies)
(type-hierarchies:get-type-hierarchy cxn-inventory))
(type-hierarchies::node-p (intern (symbol-name y) :type-hierarchies)
(type-hierarchies:get-type-hierarchy cxn-inventory))
(type-hierarchies::directed-path-p (intern (symbol-name y) :type-hierarchies)
(intern (symbol-name x) :type-hierarchies)
(type-hierarchies:get-type-hierarchy cxn-inventory))
bindings))
;; unify variables
((variable-p x) (unify-variable x y bindings))
((variable-p y) (unify-variable y x bindings))
((unify-equal x y) bindings)
(t (values +fail+ x y))))
(define-event-handler (trace-fcg cip-started)
(add-element `((hr)))
(add-element
`((h3) ,(if (children (top-node cip))
"Computing next solution for application of "
"Applying ")
; because constantly rendering the full construction inventory
; gets very slow with a large number of constructions, turn off
; rendering once the inventory gets larger than:
,(if (> (size (construction-inventory cip)) (get-configuration (construction-inventory cip)
:max-size-for-html))
(format nil "a large ~a (~d)"
(get-construction-inventory-title-string (original-cxn-set (construction-inventory cip)))
(size (original-cxn-set (construction-inventory cip))))
(make-html (original-cxn-set (construction-inventory cip))))
#+:type-hierarchies ,(if (type-hierarchies::get-type-hierarchy (original-cxn-set (construction-inventory cip)))
(make-html (type-hierarchies::get-type-hierarchy (original-cxn-set (construction-inventory cip)))
:weights? t :render-program "circo")
"")
" in "
,(if (eq (direction cip) '->) "formulation" "comprehension"))))
\ No newline at end of file
This diff is collapsed.