This is the grammar used to parse the simple example shown, and other more complex, many-state diagrams, not shown. This grammar uses specialized Lisp functions, appended the end of this grammar, to describe the detailed geometrical arrangement of the component of arrowheads.

(setf 
          
 *grammar*    ; a grammar object
 
 (defgrammar
      
   ;;; **********  < Finite Automato >  *************
   ( FA -> Init-state  Transitions  Final-states 
        (Transitions)  (Final-states)  (Init-state) ) ;

   ;;; **********  < Transitions > *************
   ( Transition -> A-state_1  Labeled-arrow  A-state_2 
      (Labeled-arrow)
      (A-state_1  (touch (leave-pt (arrow Labeled-arrow)) '?))
      (A-state_2  (touch (reach-pt (arrow Labeled-arrow)) '?)) ) ;

   ( Transitions -> set ( Transition ) ) ;
   
   ;;; **********  < Labeled-arrow > *************
   ( Label -> Text
     (Text :constraints  (numeric-textp Text)) ) ;
   
   ( Labeled-arrow -> Arrow Label 
     (Arrow) 
     (Label  (touch  Arrow '?)
             :select (min (distance (center Label) (arrow-back Arrow)))) ) ;

 ;;; **********  < Arrow >  *************
   ( Arrow -> Arrow-back  Arrow-head
     (:additional-slots (leave-pt . (get-leave-pt self))
                        (reach-pt . (pt (arrow-head self))))
     (Arrow-head)
     (Arrow-back   (extends (touch (pt arrow-head) '?))
                   :select (min (distance (list (left-endpoint arrow-back) (right-endpoint arrow-back))
                            (pt arrow-head)))) ) ;
   
   ;;; **********  < Arrow-head >  *************
   ( Arrow-head -> Short-line_1  Short-line_2
     (:additional-slots  (pt . (get-arrow-head-pts self 'common-pt))) 
     (Short-line_1)
     (Short-line_2  (touch Short-line_1 '?)
             :constraints
             (different Short-line_1  Short-line_2)
             (left  (center Short-line_1)  (center Short-line_2) :strictly t)
             (same-length (line Short-line_1) (line Short-line_2) :ratio 1.7)
             (< (distance (endpts short-line_1) (endpts short-line_2)) 
                (/ (a-length (line Short-line_1)) 5.0))) ) ;  ~ 40

    ;;; **********  < Arrow-back > *************
   ( Arrow-back -> Line 
     (:additional-slots  (left-endpoint  . (left-endpoint  (Line  self)))
                         (right-endpoint . (right-endpoint (Line  self))))
     (:constraints  (long Line :ratio 22)) ) ;

   ( Arrow-back ->  Curve-back
     (:additional-slots  (left-endpoint  . (left-endpoint  (Curve-back self)))
                         (right-endpoint . (right-endpoint (Curve-back self))))) ;

   ( Curve-back -> set ( Curve ) (:constraint connected) ) ;
   
   ;;; **********  < Short-line > *************
   ( Short-line -> Line
     (:additional-slots  (endpts . (endpoints (Line self)))
                         ;(length . (a-length (Line self)))
                         ) ;; add length
     (:constraints (short Line)) ) ;

   ;;; **********  < A-state > *************
   ( A-state -> Circle  Text
     (Circle :constraints (not (contained Circle (some* [circle]))))
     (Text   (contain Circle '?)) ) ;

   ;;; **********  < Final-states >  *************
   ( Final-state -> A-state 
      (A-state  
       :constraints (contain (circle  A-state) (some* [circle] :in (touch '? A-state)))) ) ;
   
   ( Final-states -> set ( Final-state ) ) ;

   ;;; **********  Init-state  *************
   ( Init-state -> A-state  Arrow
     (A-state)
     (Arrow  (touch A-state '?)
      :constraints  (touch (reach-pt Arrow) A-state) 
                    (null (some* [a-state] :in (touch '? (leave-pt Arrow))))) ) ;
   ) 
 )


;;; -------------------------------------------
;;;         Non supported functions
;;; -------------------------------------------
          
(defmethod left-endpoint ((go curve-back)) 
  (apply #'left-point (curve-cluster-endpoints (value go))))

(defmethod right-endpoint ((go curve-back)) 
  (apply #'right-point (curve-cluster-endpoints (value go))))

;;;
(defmethod distance ((pt a-point) (go arrow-back<1>) &key (min-max 'min))  ; <1> the first alternative in the grammar.
  (distance pt (line go)))


(defmethod distance ((pt a-point) (go arrow-back<2>) &key (min-max 'min)) 
  (pt-curve-cluster-dist pt (value (curve-back go))))


;;; -------------------------------------------
(defmethod get-arrow-head-pts ((ob arrow-head) type)
  
  (let* ((line1-end-pts (make-array '(2) 
                                    :initial-contents (a-line-terminators (line (short-line_1 ob)))))
         (line2-end-pts (make-array '(2) 
                                    :initial-contents (a-line-terminators (line (short-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)))))

;;;
(defun get-head-pt (arrow-head)
  )

;;;
(defun get-leave-pt (arrow)
  (let ((pt (pt (arrow-head arrow))))
    
    (if (> (distance pt (left-endpoint  (arrow-back arrow)))
           (distance pt (right-endpoint (arrow-back arrow))))
    (left-endpoint (arrow-back arrow))
    (right-endpoint (arrow-back arrow)))
    ))

		Back to automata example

		Back to Index page