home *** CD-ROM | disk | FTP | other *** search
/ vis-ftp.cs.umass.edu / vis-ftp.cs.umass.edu.tar / vis-ftp.cs.umass.edu / pub / Software / ASCENDER / ascendMar8.tar / UMass / ISR / isr2readisr1file.lisp < prev    next >
Lisp/Scheme  |  1995-04-11  |  17KB  |  446 lines
  1. ;;; -*- Mode:Common-Lisp; Package:isr2; Base:10; -*-
  2. ;;;------------------------------------------------------------------------
  3. ;;; ISR2READISR1FILE.LISP - Code to read isr1 (old style) files
  4. ;;; Created: Mon May 23 12:47:56 1988
  5. ;;; Author: Robert Heller
  6. ;;;------------------------------------------------------------------------
  7. ;;; Copyright (c) University of Massachusetts 1988
  8. ;;;------------------------------------------------------------------------
  9.  
  10. (in-package "ISR2")
  11.  
  12. (export 'read-isr1-feature-data)
  13.  
  14. ;; old (ISR1) lexicon structure (used to hold lexicon info during read).
  15.  
  16. (defstruct isr1-lexicon
  17.   name
  18.   doc
  19.   ptr-feature-count
  20.   num-feature-count
  21.   ext-feature-count
  22.   bp-feature-count
  23.   ptr-feature-slots
  24.   num-feature-slots
  25.   ext-feature-slots
  26.   bp-feature-slots
  27.   name-array
  28.   datatype-array
  29.   index-array
  30.   function-array
  31.   )
  32.  
  33.  
  34. (proclaim '(special NUM-ARRAY32
  35.             TOKENSET
  36.             NUM-ARRAY
  37.             NUM-INDEX
  38.             NUM-NEXT-BLOCK-LIMIT
  39.             ON-THIS-PAGE
  40.             NUM-VIRTUAL-INDEX))
  41.  
  42. (eval-when (load eval compile)
  43.        (DEFCONSTANT S-F-EXPONENT (BYTE 8 23)) 
  44.        (DEFCONSTANT S-F-EXPONENT-HIGH-BITS (BYTE 6 25)) 
  45.        (DEFCONSTANT VAX-F-EXPONENT (BYTE 8 7)) 
  46.        (DEFCONSTANT MIN-EXP 1) 
  47.        (DEFCONSTANT MAX-EXP 255) 
  48.  
  49.        (defconstant *vax-numeric-undefined* #x7FFFFFFF)
  50.  
  51.        (DEFCONSTANT *VAX-BONKED-NUMERIC-UNDEFINED* #xFEFF7FFF
  52.             "What it looks like after it's been read and converted.")
  53.  
  54.        (defconstant *vax-numeric-undefinable* #x7FFFFFFE)
  55.  
  56.        (DEFCONSTANT *VAX-BONKED-NUMERIC-UNDEFINABLE* #xFEFE7FFF
  57.             "What it looks like after it's been read and converted.")
  58.  
  59.        (defconstant *int-undefined-32b* #xafb5200)
  60.        (defconstant *int-undefinable-32b* #xafb5300)
  61.        )
  62.  
  63. ;;;  Defined in isr2fileio
  64. ;(DEFVAR *WORD* 0 "for byte depositing") 
  65. ;
  66. ;(DEFVAR *TEMP* 0 "for macros, to avoid annoying let gensym stuff") 
  67.  
  68. ;(defvar *null-extents* nil)
  69. ;(eval-when (compile load eval)
  70. ;  (setf *null-extents* (make-extents 0 0 0 0 0))) ;written out in place of undefined extents
  71.  
  72. ;;;;======================== LOW LEVEL INPUT =======================================
  73. ;(defconstant byte0 (byte 8 0))
  74. ;(defconstant byte1 (byte 8 8))
  75. ;(defconstant byte2 (byte 8 16))
  76. ;(defconstant byte3 (byte 8 24))
  77.  
  78.  
  79.  
  80. (#-(or :allegro :lispworks) defsubst #+(or :allegro :lispworks) defun read-byte8 (stream)
  81.   "read an unsigned 8 bit value from the stream."
  82.   (read-byte stream))
  83.  
  84.  
  85.  
  86. (#-(or :allegro :lispworks) defsubst #+(or :allegro :lispworks) defun READ-BYTE16 (STREAM)
  87.   "read an unsigned 16 bit value from the stream."
  88.   (DPB (READ-BYTE STREAM) BYTE0 
  89.     (DPB (READ-BYTE STREAM) BYTE1 *WORD*)))
  90.  
  91.  
  92.  
  93. (#-(or :allegro :lispworks) defsubst #+(or :allegro :lispworks) defun READ-INT16 (STREAM)
  94.   "read a signed 16 bit value from the stream."
  95.   (LET ((*TEMP* (READ-BYTE16 STREAM)))
  96.      (IF (> *TEMP* 32768)
  97.        (- *TEMP* 65536)
  98.        *TEMP*)))
  99.  
  100.  
  101.  
  102. (#-(or :allegro :lispworks) defsubst #+(or :allegro :lispworks) defun READ-BYTE32 (STREAM)
  103.   "read an unsigned 32 bit value from the stream.
  104.    Depends on left-to-right evaluation order
  105.    Abelson & Sussman forgive us."
  106.   (DPB (READ-BYTE STREAM) BYTE0
  107.     (DPB (READ-BYTE STREAM) BYTE1
  108.          (DPB (READ-BYTE STREAM) BYTE2
  109.           (DPB (READ-BYTE STREAM) BYTE3 *WORD*)))))
  110.  
  111.  
  112.  
  113. (#-(or :allegro :lispworks) defsubst #+(or :allegro :lispworks) defun read-string-n (stream length) 
  114.   (let* ((len (max 0 (1- length)))
  115.      (string  (make-array len :element-type 'string-char)))
  116.     (dotimes (i len)
  117.       (setf (aref string i) (read-char stream)))
  118.     (read-char stream)                ;discard the 0 byte
  119.     string))
  120.  
  121.  
  122. (#-(or :allegro :lispworks) defsubst #+(or :allegro :lispworks) defun READ-VAX-F-FLOAT-TO-SINGLE-FLOAT (STREAM)
  123.   "Convert vax-f-float to single-float
  124.    mem:  byte0,     byte1,    byte2    byte3   memory order low to low+3
  125.    vax: lo-byte    hi-byte   lo-byte   hi-byte (half-word)
  126.         hi-mant     s/exp     mid-mant lo-mant  (f-float)
  127.    ti:  hi-byte    lo-byte    hi       lo    (half-word)
  128.    in:     3          2        1        0 
  129.         lo-mant    mid-mant  s/exp    hi-mant (single-float)
  130.  store:    1          0        3        2
  131.    1.  words.  2. subtract 2 to convert excess-128
  132.        to excess 127--why 2???"
  133.   (SETF *TEMP*
  134.     (DPB (READ-BYTE STREAM) BYTE2
  135.          (DPB (READ-BYTE STREAM) BYTE3
  136.           (DPB (READ-BYTE STREAM) BYTE0
  137.                (DPB (READ-BYTE STREAM) BYTE1 *WORD*)))))
  138.   ;;is exponent less than 4?
  139.   (IF (ZEROP  (LDB S-F-EXPONENT-HIGH-BITS *TEMP*))
  140.       ;;ok is it zero, then leave it alone
  141.       (IF (ZEROP (LDB S-F-EXPONENT *TEMP*))
  142.       *TEMP*
  143.       ;; else make it 1
  144.       (DPB MIN-EXP S-F-EXPONENT *TEMP*))
  145.       (DPB (- (LDB S-F-EXPONENT *TEMP*) 2) S-F-EXPONENT *TEMP*)))
  146.  
  147.  
  148.    
  149.  
  150. (defconstant c255 (code-char 255))
  151.  
  152. (#-(or :allegro :lispworks) defsubst #+(or :allegro :lispworks) defun READ-STRING-N-DISCARDING-255 (STREAM LENGTH)
  153.   "THis one cannot be used for anything but pointer (string)
  154.     data.  Don't use it for getting string-length for example."
  155.   (LET* ((LEN (MAX 0 (1- LENGTH)))
  156.      (STRING (MAKE-ARRAY LEN :ELEMENT-TYPE 'STRING-CHAR))
  157.      (CHAR NIL))
  158.     (DOTIMES (I LEN)
  159.       (SETF CHAR (READ-CHAR STREAM))
  160.       (WHEN (char= CHAR C255)
  161.     (SETF CHAR #\SPACE))
  162.       (SETF (AREF STRING I) CHAR))
  163.     (READ-CHAR STREAM)
  164.     STRING)) 
  165.  
  166.  
  167.  
  168. (#-(or :allegro :lispworks) defsubst #+(or :allegro :lispworks) defun read-isr-string (stream)
  169.   "read in and return a string from the stream.  The ISR currently stores strings
  170.   as a length followed by the string, with ends with a 0 byte."
  171.   (read-string-n stream (read-byte16 stream)))
  172.  
  173. ;;;;======================= INTERMEDIATE LEVEL INPUT ==============================
  174.  
  175. (defmacro package-read-from-string (string &optional (pkg nil package-p))
  176.   "read from string into with *package* optionally set"
  177.   (if package-p
  178.       `(let ((*package* (find-package ,pkg)))
  179.      (read-from-string ,string))
  180.       `(read-from-string ,string)))
  181.  
  182. (defmacro read-isr-name (stream &optional (pkg nil package-p))
  183.   "read name, ignore the $ at the end"
  184.   (if package-p
  185.       `(package-read-from-string (string-right-trim '(#\$) (read-isr-string ,stream)) ,pkg)
  186.       `(package-read-from-string (string-right-trim '(#\$) (read-isr-string ,stream)))))
  187.  
  188. (defmacro read-sexpr (stream &optional (pkg nil package-p))
  189.   "read in a string from the stream and and then read from that
  190.    string with the current package optionally defined."
  191.   (if package-p
  192.       `(package-read-from-string (read-isr-string ,stream) ,pkg)
  193.       `(package-read-from-string (read-isr-string ,stream))))
  194.  
  195. (defmacro read-sexpr-n (stream length &optional (pkg nil package-p))
  196.   "read in a string with length n from the stream and and then
  197.    read from that string with the current package optionally defined."
  198.   (if package-p
  199.       `(package-read-from-string (read-string-n-discarding-255 ,stream ,length) ,pkg)
  200.       `(package-read-from-string (read-string-n-discarding-255 ,stream ,length))))
  201.  
  202. (defun read-extents (stream)
  203.   "read in extents from the stream and return an extents structure"
  204.   (let (#+:EXPLORER (default-cons-area *bitplane-area*))
  205.     #+:EXPLORER (declare (special default-cons-area))
  206.     (let ((ext (make-extents-struct)))
  207.       (setf (extents-byte-bound ext) (read-int16 stream))
  208.       (setf (extents-byte-width ext) (read-byte16 stream))
  209.       (setf (extents-minx ext) (read-int16 stream))
  210.       (setf (extents-miny ext) (read-int16 stream))
  211.       (setf (extents-maxx ext) (read-int16 stream))
  212.       (setf (extents-maxy ext) (read-int16 stream))
  213.       (setf (extents-pixel-count ext) (read-byte16 stream))
  214.       ext)))
  215.  
  216. (defun read-bitplane (stream extents)
  217.   "read in bitplane having given extents from the stream and return a bitplane array.
  218.    Bitplane is padded so that it is always a multiple of 32 bits wide.
  219.    hackery alert!!, extents may be modified as a side-effect."
  220.   (let ((numbytes (read-byte32 stream)))
  221.     (if (not (zerop numbytes))
  222.     (progn 
  223.       (let ((byte-width (extents-byte-width extents))
  224.         (height (1+ (- (extents-maxy extents) (extents-miny extents)))))
  225.            (if (not (= numbytes (* height byte-width)))
  226.            (error "number of bytes in bitplane is ~d, it should be ~d"
  227.               numbytes (* height byte-width))
  228.            ;;else read in the bitplane, padding it accordingly
  229.            (let ((new-byte-width (* 4 (ceiling byte-width 4))) ;next highest multiple of 32 bits
  230.              #+:EXPLORER (default-cons-area *bitplane-area*))
  231.             #+:EXPLORER (declare (special default-cons-area))
  232.             (let ((bitplane 
  233.                 (make-array (list height new-byte-width) :element-type '(unsigned-byte 8))))
  234.                  (dotimes (y height)
  235.                       (dotimes (x byte-width)
  236.                            (setf (aref bitplane y x)
  237.                              (read-byte8 stream))))       ;read in bitplane
  238.                  (setf (extents-byte-width extents) new-byte-width)
  239.                  (make-array (list height (* 8 new-byte-width))
  240.                      :element-type 'bit
  241.                      :displaced-to bitplane))))))
  242.     *ptr-undefined*)
  243.     )
  244.   )
  245.  
  246.  
  247. (defun read-isr1-lexicon (stream)
  248.   "read in a isr1-lexicon definition from the stream.  Returns a isr1-lexicon structure."
  249.   (let ((lex (make-isr1-lexicon)))
  250.     (setf (isr1-lexicon-name lex) (read-sexpr stream "ISR"))  ;; instead of simple-name
  251.     (setf (isr1-lexicon-doc lex) (read-isr-string stream))
  252.     (setf (isr1-lexicon-num-feature-slots lex) (read-byte16 stream))
  253.     (setf (isr1-lexicon-num-feature-count lex) (read-byte16 stream))
  254.     (setf (isr1-lexicon-ptr-feature-slots lex) (read-byte16 stream))
  255.     (setf (isr1-lexicon-ptr-feature-count lex) (read-byte16 stream))
  256.     (setf (isr1-lexicon-ext-feature-slots lex) 1)
  257.     (setf (isr1-lexicon-ext-feature-count lex) 1)
  258.     (setf (isr1-lexicon-bp-feature-slots  lex) 1)
  259.     (setf (isr1-lexicon-bp-feature-count lex) 1)
  260.     (let ((total-count (+ 2 (isr1-lexicon-num-feature-count lex) (isr1-lexicon-ptr-feature-count lex))))
  261.       ;; get ready for creating the feature table
  262.       (let ((name-array (make-array total-count :element-type t))
  263.         (function-array (make-array total-count :element-type t))
  264.         (datatype-array (make-array total-count :element-type '(unsigned-byte 8)))
  265.         (index-array (make-array total-count :element-type '(unsigned-byte 16))))
  266.     ;; read feature names and function names into user package
  267.     ;; read in feature names
  268.     (dotimes (i total-count) (setf (aref name-array i) (read-sexpr stream "ISR")))
  269.     (let ((*package* (find-package "USER")))
  270.       ;; read in feature functions
  271.       (dotimes (i total-count) (setf (aref function-array i) (read-sexpr stream))))
  272.     ;; read in datatypes
  273.     (dotimes (i total-count) (setf (aref datatype-array i) (read-byte8 stream)))
  274.     ;; read in feature indices
  275.     (dotimes (i total-count) (setf (aref index-array i) (read-byte16 stream)))
  276.     (setf (isr1-lexicon-name-array lex) name-array
  277.           (isr1-lexicon-datatype-array lex) datatype-array
  278.           (isr1-lexicon-index-array lex) index-array
  279.           (isr1-lexicon-function-array lex) function-array
  280.           )))
  281.     lex))
  282.  
  283.  
  284. (defvar user::*isrread$dir* "") 
  285.  
  286. (defun read-isr1-feature-data (filename &optional default-directory)
  287.   "READ-ISR1-FEATURE-DATA filename &OPTIONAL default-directory - Read an
  288. old (ISR1) feature data file into the ISR2 DataBase.  The image name is 
  289. used as the name of a frame under root and the tokenset name is used as a
  290. name of a frame feature (also a frame) under the imagename frame.  The image
  291. name frame is created if it does not exist.  If the tokenset name exists as
  292. a frame feature an error is generated."
  293.   (declare (special user::*isrread$dir*))
  294.   (declare (arglist (filename &optional (default-directory user::*isrread$dir*))))
  295.   (when (and (not default-directory) (boundp 'user::*isrread$dir*))
  296.     (setq default-directory user::*isrread$dir*))
  297.   (with-open-file (file (merge-pathnames filename default-directory)
  298.             :direction :input
  299.             :element-type '(unsigned-byte 8))2
  300.     (let* ((imagename (read-isr-name file "ISR2"))
  301.        (image-frame-handle (or (let ((h (%internal-handle imagename 
  302.                             :error-p nil :terminal-p t)))
  303.                     (if (handle-p h) h nil))
  304.                    (create imagename)))
  305.        (tokensetname (read-isr-name file "ISR2"))
  306.        (isr1-lexicon (read-isr1-lexicon file))
  307.        (tokenset-handle (create (list image-frame-handle tokensetname)))
  308.        (tokcount (read-byte32 file))
  309.        (name-array (isr1-lexicon-name-array isr1-lexicon))
  310.        (datatype-array (isr1-lexicon-datatype-array isr1-lexicon))
  311.        (index-array (isr1-lexicon-index-array isr1-lexicon))
  312.        (function-array (isr1-lexicon-function-array isr1-lexicon))
  313.        (num-feature-slots (isr1-lexicon-num-feature-slots isr1-lexicon))
  314.        (ptr-feature-slots (isr1-lexicon-ptr-feature-slots isr1-lexicon))
  315.        (dummy-token-handle (make-handle :type :token
  316.                         :frame (handle-frame tokenset-handle)
  317.                         :token :?))
  318.        num-names num-types
  319.        ptr-names
  320.        )
  321.       (read-byte32 file)    ;count of token slots goes into the bitbucket
  322.       (setf #|(value (list image-frame-handle tokensetname "F_DOCUMENTATION"))
  323.         (isr1-lexicon-doc isr1-lexicon) |#
  324.         (value (list tokenset-handle "DOCUMENTATION"))
  325.         (isr1-lexicon-doc isr1-lexicon)
  326.         )
  327.       (map nil
  328.        #'(lambda (fname datatype function)
  329.         (define-feature (list dummy-token-handle fname)
  330.                 (format nil "On-Demand function was ~A" function)
  331.                 (case datatype
  332.                       (#.*int* :integer)
  333.                       (#.*real* :real)
  334.                       (#.*extents* :extents)
  335.                       (#.*bitplane* :bitplane)
  336.                       (#.*pointer* :pointer))))
  337.        name-array datatype-array function-array)
  338.       (multiple-value-setq (num-names num-types ptr-names)
  339.     (map-and-extract-feature-block name-array datatype-array index-array
  340.                        num-feature-slots ptr-feature-slots))
  341.       (define-pixelmap-feature 
  342.     (list tokenset-handle "<?>pixelmap")
  343.     "Pixelmap feature (composite feature of EXTENTS and BITPLANE)"
  344.     )
  345.       ;; read in tokens, keeping track of the highest index 
  346.       (do ((i (max tokcount 0) (1- i))
  347.        (curtok -1)
  348.        token-handle
  349.        )
  350.       ((zerop i) curtok)
  351.       (setf curtok (read-byte32 file))
  352.       (setf token-handle (create (list tokenset-handle curtok)))
  353.       (READ-EXTENTS-AND-BITPLANE file token-handle)
  354.       (READ-NUMERIC-FEATURES     file token-handle num-names num-types)
  355.       (READ-POINTER-FEATURES     file token-handle ptr-names))
  356.       )
  357.     )
  358.   )
  359.  
  360.  
  361. (defun map-and-extract-feature-block (names datatypes indexes num-count ptr-count)
  362.   (let ((num-names (make-array num-count))
  363.     (num-types (make-array num-count))
  364.     (ptr-names (make-array ptr-count)))
  365.        (dotimes (i (length names))
  366.         (cond ((= (aref datatypes i) *pointer*)
  367.                (setf (aref ptr-names (aref indexes i)) (aref names i)))
  368.               ((or (= (aref datatypes i) *int*)
  369.                (= (aref datatypes i) *real*))
  370.                (setf (aref num-names (aref indexes i)) (aref names i)
  371.                  (aref num-types (aref indexes i)) (aref datatypes i)
  372.                  )
  373.                )
  374.               ))
  375.        (values num-names num-types ptr-names)
  376.        )
  377.   )
  378.  
  379.  
  380. (defun READ-EXTENTS-AND-BITPLANE (stream token-handle)
  381.   (let* ((extents (read-extents stream))
  382.      (bitplane (read-bitplane stream extents)))
  383.     (setf (value (list token-handle "EXTENTS")) (if (zerop (extents-pixel-count
  384.                                  extents))
  385.                             *ptr-undefined*
  386.                             extents)
  387.           (value (list token-handle "BITPLANE")) bitplane)
  388.     )
  389.   )
  390.  
  391. (defun READ-NUMERIC-FEATURES (stream token-handle name-array datatype-array
  392.                   &aux value (value-union (make-array 1 :element-type '(unsigned-byte 32)))
  393.                   (ival (make-array 1 :element-type 'fixnum
  394.                           :displaced-to value-union))
  395.                   (fval (make-array 1 :element-type 'single-float
  396.                           :displaced-to value-union))
  397.                   )
  398.   (map nil #'(lambda (name datatype)
  399.         (cond ((null datatype) (read-byte32 stream))
  400.               ((= datatype *int*)
  401.                (setf value (READ-BYTE32 stream))
  402.                (case value
  403.                  (#.*vax-numeric-undefined* nil)
  404.                  (#.*vax-numeric-undefinable*
  405.                    (setf (value (list token-handle name))
  406.                      *int-undefinable*))
  407.                  (t (setf (aref value-union 0) value
  408.                       (value (list token-handle name))
  409.                       (aref ival 0)))))
  410.               ((= datatype *real*)
  411.                (setf value (READ-VAX-F-FLOAT-TO-SINGLE-FLOAT stream))
  412.                #|(break "~&Reading (~S ~S): value = ~8,'0x" token-handle 
  413.                   name value)|#
  414.                (case value
  415.                  (#.*vax-bonked-numeric-undefined* nil)
  416.                  (#.*vax-bonked-numeric-undefinable*
  417.                    (setf (value (list token-handle name))
  418.                      *real-undefinable*))
  419.                  (t (setf (aref value-union 0) value
  420.                       (value (list token-handle name))
  421.                       (aref fval 0)))))
  422.               (t t))
  423.         )
  424.        name-array
  425.        datatype-array)
  426.   )
  427.  
  428. (eval-when (compile load eval)
  429.    (defconstant ptr-feature-defined?-field (byte 1 0)))
  430. (defconstant ptr-feature-length-field (byte 15 1))
  431. (defconstant ptr-is-defined (dpb 1 ptr-feature-defined?-field 0))
  432. (defmacro ptr-feature-defined? (ptr-header) `(plusp (ldb ptr-feature-defined?-field ,ptr-header)))
  433. (defmacro ptr-feature-length (ptr-header) `(ldb ptr-feature-length-field ,ptr-header))
  434.  
  435. (defun READ-POINTER-FEATURES (stream token-handle name-array
  436.                   &aux ptr-header (*package* (find-package "USER")))
  437.   (map nil #'(lambda (name)
  438.         (when (ptr-feature-defined? 
  439.             (setf ptr-header (read-byte16 stream)))
  440.           (setf (value (list token-handle name))
  441.             (read-sexpr-n stream (ptr-feature-length ptr-header))))
  442.         )
  443.        name-array
  444.        )
  445.   )
  446.