Note that the grammar is followed by definitions of some Lisp functions called during parsing, especially to deal with the details of arrow-points (arrowheads).
;;;-*- Mode: Lisp; Package: DUS -*-
;;; -----------------------------
;;;
;;; Nikos Nikolakis
;;;
;;; created: Oct. 1994
;;; last update: 2/28/95
;;; -----------------------------
#|
An effort to parse a diagram through a declarative approach.
This grammar works fine for diagrams with non-overlapping axis.
The grammar has been extended to handle special cases like
annotations, key-specifications and other objects inside a diagram.
|#
(defvar *tiny* 35) ; it specifies the coincide predicate (old value 20)
(setf
*grammar* ;; grammar object
(defgrammar
;;; ****************** < Image > ******************
( Image -> Set ( Diagram ) );
;;; ****************** < Diagram > ******************
( Diagram -> Axis X-Axis Y-Axis Data
(Axis)
(X-Axis ($ :axis Axis))
(Y-Axis ($ :axis Axis))
(Data
($ (difference* (contain Axis '?)
(union* X-Axis Y-Axis))
:x-ln (ln (X-Line Axis))
:y-ln (ln (Y-Line Axis))
:axis Axis)) );
;;; ****************** < Axis > ******************
( Axis -> X-Line Y-Line
(X-Line)
(Y-Line (touch (left-endpoint X-Line) '?)
:constraints
(coincide (left-endpoint X-Line) (bottom-endpoint Y-Line))) );
( X-Line -> Line
(:additional-slots (left-endpoint . (left-endpoint (Line self)))
(ln . (a-length (Line self))))
(:constraints
(horizp Line) (long Line)) );
( Y-Line -> Line
(:additional-slots (bottom-endpoint . (bottom-endpoint (Line self)))
(ln . (a-length (Line self))))
(:constraints
(vertp Line) (long Line)) );
;;; ****************** < X-AXIS > ******************
( X-Axis -> X-Axis-Line X-Ticks X-Labels X-Annotation X-Text
(:optional X-Annotation X-Text)
(X-Axis-Line (X-Line (get-val axis)))
(X-Ticks ($ :x-line X-Axis-Line) :constraints (>= (size X-Ticks) 3))
(X-Labels (below '? X-Axis-Line :strip t))
(X-Annotation (difference* (near X-Axis-Line 700) (union* X-Ticks X-Labels))) ; label-size
(X-Text (near&below '? X-Labels (* 2 (height X-Labels)))
) )
( X-Ticks -> X-or < (Own-X-Ticks (touch '? (get-val X-Line)))
(Remote-X-Ticks (below '? (get-val X-Line) :strip t)) > );
( Own-X-Ticks -> Set ( Line )
(:element-constraints
(vertp Line) (short Line) (not (polylinep Line))
(< (distance (endpoints Line) (Line (get-val X-Line)))
(max (* (a-length Line) .25) *tiny*)))
(:constraint horiz-aligned-gen)
(:largest t) );
( Remote-X-Ticks -> Set ( Line )
(:element-constraints
(vertp Line) (short Line) (not (polylinep Line)))
(:constraint horiz-aligned-gen)
(:largest t) );
( X-Labels -> Set ( Text )
(:element-constraints (horizp Text) (numeric-textp Text) )
(:constraint horiz-aligned-gen)
(:largest t) );
( X-Text -> Text
(Text
:constraints (horizp Text) (not (numeric-textp Text))
:select (max (text-length Text))) );
;;; The arrow points to the X-line (=> we don't need the pointed-gos
( X-Annotation -> Arrow Text-set
(:optional Text)
(:non-sharable Arrow Text-set)
(Arrow)
(Text-set (near (leave-pt Arrow) (* 3.5 (ln Arrow)))) );
;;; ****************** < Y-AXIS > ******************
( Y-Axis -> Y-Axis-Line Y-Ticks Y-Labels Y-Text
(:optional Y-Ticks Y-Labels Y-text)
(Y-Axis-Line (Y-Line (get-val axis)))
(Y-Ticks ($ :y-line Y-Axis-Line))
(Y-Labels (left '? Y-Axis-Line :entirely nil :strip t))
(Y-Text ($ (left '? (or Y-Labels Y-Axis-Line))
:dist (width Y-Labels))
:select (min (distance (center Y-Axis-Line) (center Y-Text)))) );
( Y-Ticks -> X-or < (Own-Y-Ticks (touch '? (get-val Y-Line)))
(Remote-Y-Ticks (left '? (get-val Y-Line) :strip t)
:filter (some* [Y-Labels] :in (touch '? Remote-Y-Ticks) :gen t)) > );
( Own-Y-Ticks -> Set ( Line )
(:element-constraints
(horizp Line) (short Line)
(not (polylinep Line))
(< (distance (endpoints Line) (Line (get-val Y-Line)))
(max (* (a-length Line) .25) *tiny*)))
(:constraint vert-aligned-gen)
(:largest t) )
( Remote-Y-Ticks -> Set ( Line )
(:element-constraints
(horizp Line) (short Line) (not (polylinep Line)))
(:constraint vert-aligned-gen) );
( Y-Labels -> Set ( Text )
(:element-constraints (horizp Text) (numeric-textp Text) )
(:constraint vert-aligned-gen)
(:largest t) );
( Y-Text -> Set ( Text )
(:element-constraints (vertp Text))
(:constraint (close-gen :how-near (get-val dist))) );
;;; ****************** < DATA > ******************
( Data -> Data-lines Data-points Annotations Key-specifications
(:optional Data-lines Data-points Annotations Key-specifications)
(Key-specifications)
(Data-lines)
(Annotations (difference* context Data-lines))
(Data-points (difference* context Data-lines)) );
;;; ****************** < DATA-LINES > ******************
( Data-lines -> set ( Data-line )
(:element-constraints
(> (a-length data-line) (* .25 (get-val x-ln)))));
( Data-line -> set ( Line )
(:element-constraints
(not (polylinep Line))
(not (or (and (horizp line) (> (a-length line) (* .7 (get-val x-ln)))
(< (distance (left-endpoint line)
(Line (Y-Line (get-val axis)))) *tiny*))
(and (vertp line) (> (a-length line) (* .7 (get-val y-ln)))))))
(:constraint connected) ) ;
( Data-line -> set ( Curve ) (:constraint connected)) ;
;;; ****************** < Data-points > ******************
( Data-Points -> set ( Data-Cluster ) ); ={ circle-dp, traingle-dp, rectangle-dp }
; An example of a data-cluster is the set of all circle-data points
( Data-Cluster -> set ( Data-point ) (:constraint same-type) ) ;
( Data-point -> circle
(:constraints (whitep circle)) ); a white circle
( Data-point -> circle
(:constraints (blackp circle)) ); a black circle
( Data-point -> polygon ; a rectangle
(:constraints (rectangle? polygon) (small polygon)) ) ;
( Data-point -> line_1 line_2 line_3 ; a triangle
(line_1)
(line_2 (touch '? (right-endpoint line_1))
:constraints
(different line_1 line_2)
(coincide (right-endpoint line_1) (left-endpoint line_2)))
(line_3 (touch '? (right-endpoint line_2))
:constraints
(different line_2 line_3) (different line_1 line_3)
(coincide (right-endpoint line_2) (right-endpoint line_3))
(coincide (left-endpoint line_1) (left-endpoint line_3))) );
( Data-point -> line_1 line_2 line_3 line_4 ; a diamond
(line_1
:constraints (not (horizp line_1)) (not (vertp line_1)))
(line_2 (touch '? (right-endpoint line_1))
:constraints
(< (distance (right-endpoint line_1) (left-endpoint line_2)) *tiny*)
(not (horizp line_2))
(not (vertp line_2)))
(line_3 (touch '? (right-endpoint (line_2 obj)))
:constraints
(< (distance (right-endpoint line_2) (right-endpoint line_3)) *tiny*)
(different line_3 line_2))
(line_4 (touch '? (left-endpoint line_3))
:constraints
(< (distance (left-endpoint line_3) (right-endpoint line_4)) *tiny*)
(< (distance (left-endpoint line_1) (left-endpoint line_4)) *tiny*)
(parallelp line_1 line_3)
(above (right-endpoint line_1) (right-endpoint line_4))) );
;;; ****************** < Annotations > ******************
(Annotations -> set ( Annotation ) );
;;; When a new set-context is specified (in a normal rule), it overwrires the previous one.
;;; // extend relation for set rules.
;;; We could have done: (gen (intersect old-context new-fun))).
(Annotation -> Text-set Arrow Pointed
(:optional Text Pointed)
(Arrow)
(Text-set (intersect* (near (leave-pt Arrow) (* 2 (ln Arrow)))
context)
;:select (min (distance (center Text) (line (arrow-back Arrow))))
)
(Pointed (near (pt (arrow-head arrow)) (* 2 (a-length (Line (Arrow-back Arrow)))))) );
( Text-set -> set ( Text )
(:element-constraints
(horizp Text) (not (numeric-textp text))) );
( Pointed -> set ( Object ) );
( Object -> Data-point );
( Object -> Text );
;;; ****************** < Arrow > ******************
( Arrow-back -> Line
(:additional-slots
(left-endpoint . (left-endpoint (Line self)))
(right-endpoint . (right-endpoint (Line self)))
(ln . (a-length (Line self))))
(:constraints (not (polylinep line))) ); <---
( Arrow-head -> Line_1 Line_2 ; works OK
(:additional-slots
(pt . (get-arrow-head-pts self 'common-pt))
(p1 . (get-arrow-head-pts self 'p1))
(p2 . (get-arrow-head-pts self 'p2)))
(Line_1
:constraints (short Line_1) (not (polylinep Line_1)))
(Line_2 (touch Line_1 '?)
:constraints
(left (center Line_1) (center Line_2)) ; impose ordering
(short Line_2)
(not (polylinep Line_2))
(same-length Line_1 Line_2 :ratio 1.2)
(< (distance (endpoints Line_1) (endpoints Line_2)) 40)) );
( Arrow -> Arrow-back Arrow-head ; works OK
(:non-sharable Arrow-head)
(:additional-slots
(leave-pt . (if (> (distance (pt (Arrow-head self)) (left-endpoint (Arrow-back self)))
(distance (pt (Arrow-head self)) (right-endpoint (Arrow-back self))))
(left-endpoint (Arrow-back self)) (right-endpoint (Arrow-back self))))
(reach-pt . (pt (arrow-head self)))
(ln . (ln (Arrow-back self))))
(arrow-head)
(arrow-back (intersect* (near (pt arrow-head) (height Arrow-head)) context) ;;; <-- put line_1
:constraints
(in-angle (pt Arrow-head) (p1 Arrow-head) (p2 Arrow-head) (left-endpoint Arrow-back))
(in-angle (pt Arrow-head) (p1 Arrow-head) (p2 Arrow-head) (right-endpoint Arrow-back))
(< (distance (pt Arrow-head) (endpoints (line Arrow-back)))
(* 1.5 (a-length (line_1 arrow-head))))
(same-angle (angle (left-endpoint Arrow-back) (pt Arrow-head))
(angle (right-endpoint Arrow-back) (pt Arrow-head)))
:select
(max (a-length (line Arrow-back)))) );
;;; ************** < Key-specifications > *******************
( Key-specification -> Expl Data-Points
(:non-sharable Data-Points)
(Expl :constraints (>= (size Expl) 2))
(Data-Points (near Expl 300)) );
( Expl -> Set ( Text ) ; Left-Aligned text
(:element-constraints
(horizp Text) (not (numeric-textp Text)) (> (text-length Text) 3))
(:constraint (vert-aligned-gen :left t)) );
( Expl -> Set ( Text ) ; Right-Aligned Text
(:element-constraints
(horizp Text) (not (numeric-textp Text)) (> (text-length Text) 3))
(:constraint (vert-aligned-gen :right t)) );
( Key-specifications -> Set ( Key-specification ) );
)
)
;;; -------------------------------------------------------
;;; Terminal generators for non-primitive terminals
;;; -------------------------------------------------------
;;;
(defun gen-x-axis-line (context)
(list context))
;;;
(defun gen-y-axis-line (context)
(list context))
;;;
(defun coincide (x y &key (dist *tiny*))
(< (distance x y) dist))
;;; -------------------------------------------------------
;;; Non-supported relations
;;; -------------------------------------------------------
(defmethod a-length ((data-line data-line))
(data-line-length data-line))
(defmethod data-line-length ((data-line data-line))
(apply #'+
(mapcar
#'(lambda (x) (distance (left-endpoint x) (right-endpoint x)))
(value data-line))))
(defun distance-pt-from-data-line (x dl)
(distance-pt-from-lines x (value dl)))
;;;
(defmethod get-arrow-head-pts ((ob arrow-head) type)
(let* ((line1-end-pts (make-array '(2)
:initial-contents (a-line-terminators (line_1 ob))))
(line2-end-pts (make-array '(2)
:initial-contents (a-line-terminators (line_2 ob))))
(distance-array (make-array '(2 2) :initial-element nil)))
(dotimes (i 2)
(dotimes (j 2)
(setf (aref distance-array i j)
(distance (aref line1-end-pts i) (aref line2-end-pts j)))))
(let (common-pt f-p1 f-p2 min id-1 id-2);
;; common-pt corresponds to the "corner" point of the arrow head
(setf min (aref distance-array 0 0))
(dotimes (i 2)
(dotimes (j 2)
(when (<= (aref distance-array i j) min)
(setf min (aref distance-array i j))
(setf id-1 i)
(setf id-2 j))))
(setf common-pt (aref line1-end-pts id-1))
(setf f-p1 (aref line1-end-pts (- 1 id-1)))
(setf f-p2 (aref line2-end-pts (- 1 id-2)))
(cond ((equal type 'all) (list common-pt f-p1 f-p2))
((equal type 'common-pt) common-pt)
((equal type 'p1) f-p1)
(t f-p2)))))
|
Next: How the Grammar Rules Drive the Parsing Process |
 |
Back to Index page |