;;;; -*- mode:lisp;coding:utf-8 -*-
;;;;**************************************************************************
;;;;FILE:               gml.lisp
;;;;LANGUAGE:           Common-Lisp
;;;;SYSTEM:             Common-Lisp
;;;;USER-INTERFACE:     NONE
;;;;DESCRIPTION
;;;;
;;;;    Read and write GML files.
;;;;
;;;;    GML-LIST are a-list of pairs (key . value).
;;;;    The key is a keyword representing the GML key.
;;;;    It's the upper-cased keyword for a safe key, and
;;;;    the as-is mixed-case keyword for an unsafe key.
;;;;    The value is the GML value, of type either INTEGER, FLOAT,
;;;;    STRING or GML-LIST.
;;;;
;;;;    Not implemented yet: the iso-8859-1 entity encoding for the strings.
;;;;    Notice that real numbers are always written with 'e' as exponent marker,
;;;;    so their exact lisp type is lost (use *read-default-float-format*).
;;;;
;;;;    Also, the limits on integer and float sizes are not enforced; the
;;;;    application must take care of converting them to string when too big.
;;;;
;;;;AUTHORS
;;;;    <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
;;;;MODIFICATIONS
;;;;    2009-08-12 <PJB> Completed.
;;;;    2009-07-25 <PJB> Created.
;;;;BUGS
;;;;LEGAL
;;;;    GPL
;;;;
;;;;    Copyright Pascal J. Bourguignon 2009 - 2009
;;;;
;;;;    This program is free software; you can redistribute it and/or
;;;;    modify it under the terms of the GNU General Public License
;;;;    as published by the Free Software Foundation; either version
;;;;    2 of the License, or (at your option) any later version.
;;;;
;;;;    This program is distributed in the hope that it will be
;;;;    useful, but WITHOUT ANY WARRANTY; without even the implied
;;;;    warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;;;;    PURPOSE.  See the GNU General Public License for more details.
;;;;
;;;;    You should have received a copy of the GNU General Public
;;;;    License along with this program; if not, write to the Free
;;;;    Software Foundation, Inc., 59 Temple Place, Suite 330,
;;;;    Boston, MA 02111-1307 USA
;;;;**************************************************************************

(defpackage "COM.INFORMATIMAGO.COMMON-LISP.GML"
  (:use "COMMON-LISP")
  (:export "READ-GML-FILE" "WRITE-GML-FILE"
           "READ-GML-STREAM" "WRITE-GML-STREAM"
           "WRITE-GML-PAIR")
  (:documentation ""))
(in-package "COM.INFORMATIMAGO.COMMON-LISP.GML")


;; GML        ::= List
;; List       ::= ε | KeyValue ( WhiteSpace+ KeyValue )*
;; KeyValue   ::= Key WhiteSpace+ Value
;; Value      ::= Integer | Real | String | '[' List ']'
;; Key        ::= [a-zA-Z][a-zA-Z0-9]*
;; Integer    ::= Sign Digit+
;; Real       ::= Sign Digit+ '.' Digit+ Exponent
;; String     ::= '"' InString '"'
;; Sign       ::= ε | '+' | '-'
;; Digit      ::= [0-9]
;; Exponent   ::= ε | 'E' Sign Digit+ | 'e' Sign Digit+
;; InString   ::= ASCII-{'&','"'} | '&' character* ';'
;; WhiteSpace ::= space | tabulator | newline


;; * ISO-8859 Character Set ; non ASCII characters are encoded in
;;   string as &...; entities.
;;
;; * Maximum line length is 254 characters.
;;
;; * Maximum Key size is 126 characters.
;;
;; * Line starting with: WhiteSpace+ '#'  is ignored
;;
;; * It is legal to have duplicate keys, order of duplicate keys must
;;   be preserved, so they may represent arrays. (But the order of the
;;   keys in general need not be preserved).
;;
;; * Keys with default values may be omited:
;;    + Integer:   0
;;    + Real:      0.0
;;    + String:    ""
;;    + List:      []
;;
;; * Key starts with a lower   case letter <=> Safe   object
;; * Key starts with a capital case letter <=> Unsafe object
;;
;; * boolean is integer (0 = false, non-0 = true)
;;

(defparameter *attributes*
  '(
    ;; name    type      context
    ;; ----------------------------
    ;; global attributes
    ("id"      integer   anywhere)
    ("label"   string    anywhere)
    ("comment" string    anywhere)
    ("Creator" string    anywhere)
    ("name"    string    anywhere)
    ;; toplevel attributes
    ("graph"   list      top)
    ("Version" integer   top)
    ("Creator" string    top)
    ;; graph attributes
    ("directed" boolean  ".graph")
    ("node"     list     ".graph")
    ("edge"     list     ".graph")
    ;; node attributes
    ("id"         integer  ".graph.node")
    ("edgeAnchor" string   ".graph.node")
    ;; graphics attributes
    ("x"          real     ".graphics")
    ("y"          real     ".graphics")
    ("z"          real     ".graphics.center")
    ("w"          real     ".graphics")
    ("h"          real     ".graphics")
    ("d"          real     ".graphics")
    ("type"       string   ".graphics")
    ;; type may be  "arc" "bitmap" "image" "line" "oval" "polygon" "rectangle" "text"
    ("image"      string   ".graphics") ; name of image file
    ("bitmap"     string   ".graphics") ; name of bitmap file
    ("point"      list     ".graphics.Line")
    ("point.x"    real     ".graphics.Line")
    ("point.y"    real     ".graphics.Line")
    ("point.z"    real     ".graphics.Line")
    ("width"      real     ".edge.graphics")
    ("stipple"    string   ".edge.graphics") ; pattern to draw the line.
    ("source"     integer  ".edge")
    ("target"     integer  ".edge")))



(defun make-gml-readtable ()
  (let ((original (copy-readtable nil))
        (gml-rt   (copy-readtable nil)))
    (setf (readtable-case gml-rt) :invert)
    (loop
       :for ch :across "!#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_`abcdefghijklmnopqrstuvwxyz{|}~" ; removed #\"
       :do (set-syntax-from-char ch #\A  gml-rt original))
    (set-macro-character #\# (get-macro-character #\; original) nil gml-rt)
    (set-macro-character #\" (lambda (stream character)
                               (declare (ignore character))
                               (loop
                                  :named read-string
                                  :with escape = nil
                                  :with result = (make-array 0 :fill-pointer 0 :adjustable t :element-type 'character)
                                  :for ch = (read-char stream nil nil)
                                  :while ch
                                  :do (if escape
                                          (progn
                                            (vector-push-extend ch result)
                                            (setf escape nil))
                                          (cond
                                            ((char= #\\ ch)
                                             (setf escape t))
                                            ((char= #\" ch)
                                             (return-from read-string result))
                                            (t
                                             (vector-push-extend ch result))))))
                         nil gml-rt)
    (set-macro-character #\[ (lambda (stream character)
                               (declare (ignore character))
                               (read-delimited-list #\] stream t)) nil gml-rt)
    gml-rt))

(defparameter *gml-readtable* (make-gml-readtable))

(defun gmlize (list)
  (loop
     :for (k v) :on list :by (function cddr)
     :collect (cons k (if (listp v)
                          (gmlize v)
                          v))))



(defun read-gml-file (gml-file-pathname)
  "Return the GML-LIST of objects read from the GML file at GML-FILE-PATHNAME."
  (with-open-file (input gml-file-pathname)
    (read-gml-stream input)))


(defun read-gml-stream (stream)
  "Return the GML-LIST of objects read from the STREAM."
  (let ((*readtable* *gml-readtable*)
        (*package*   (find-package "KEYWORD")))
    (gmlize (loop
               :for item = (read stream nil stream)
               :until (eq item stream)
               :collect item))))



(defun write-gml-pair (object stream)
  "
OBJECT: Must be a (cons key value).
KEY:    A symbol denoting the GML key.
VALUE:  A GML value (either an INTEGER, a FLOAT, a STRING or a LIST of GML objects (an a-list).
"
  (check-type object cons)
  (destructuring-bind (key . value) object
    (terpri stream)
    (if (notany (function lower-case-p) (string key))
        (princ (string-downcase key) stream)
        (princ (string key) stream))
    (princ " " stream)
    (etypecase value
      (integer (prin1 value stream) (princ " " stream))
      (float   (let ((buffer (prin1-to-string value)))
                 (dolist (expo '(#\s #\e #\f #\d #\l))
                   (setf buffer (substitute #\e expo buffer :test (function char-equal))))
                 (princ buffer stream) (princ " " stream)))
      (string  (let ((buffer (prin1-to-string value))) ; TODO: use ISO-8859-1 entities!
                 (cond
                   ((< (+ 1 (length (princ-to-string key)) (length buffer)) 255)
                    (princ buffer stream))
                   ((< (length buffer) 255)
                    (terpri stream) (princ buffer stream))
                   (t
                    (error "Key ~A has a string value too long to be written in a GML file ~
                           (maximum line length is 255).~%~S" key value)))
                 (princ " " stream)))
      (list    (princ "[" stream)
               (loop :for pair :in value :do (write-gml-pair pair stream))
               (princ "]" stream))))
  object)



(defun write-gml-file (gml-list gml-file-pathname
                   &key (if-does-not-exist :create) (if-exists :supersede))
  "Write the GML-LIST to the file at GML-FILE-PATHNAME."
  (with-open-file (output  gml-file-pathname
                           :direction :output
                           :if-does-not-exist if-does-not-exist
                           :if-exists if-exists)
    (write-gml-stream gml-list output)))


(defun write-gml-stream (gml-list stream)
  "Write the GML-LIST to the STREAM."
  (loop :for pair :in gml-list :do (write-gml-pair pair stream))
  (terpri stream)
  gml-list)


;;;; THE END ;;;;
ViewGit