[Axiom-developer] No progress on notangle :-(

[C Y]

I have tried to use read-sequence to load a file quickly, which works
fine, but I'm afraid I haven't done too well with the problem of
working with the resulting string.  The code so far is actually slower
than the earlier version, and from what I can tell the primary issue
seems to be too many subseq operations on the big one-pamphlet string. 
I tried leaving the string intact and just identifying positions rather
than chopping it off as I scanned, but the searches got progressively
more expensive even though I was supplying new start positions. 
There's probably a better way to do it or an obvious mistake in the way
I have done it, but I'm afraid I've been staring at it a bit too long. 

(defvar startchars "<<")
(defvar endchars ">>=")
(defvar endchunkchars "@")
(defvar refstartchars "<<")
(defvar refendchars ">>") 

(defparameter *chunk-hash-table* (make-hash-table :test 'equal))

(defclass chunk ()
  ((chunk-name
    :initarg :chunk-name
    :initform (error "Must supply a chunk name.")
    :reader chunk-name
    :documentation "Name of chunk.")
   (chunk-contents
    :initarg :chunk-contents
    :initform ""
    :accessor chunk-contents
    :documentation "Text of chunk - may include references to other
chunks")))

(defun make-new-chunk (curr-chunk-name curr-chunk-contents)
  (setf (gethash curr-chunk-name *chunk-hash-table*) 
        (make-instance 'chunk :chunk-name curr-chunk-name
:chunk-contents curr-chunk-contents)))

(defun get-chunk-contents (curr-chunk-name)
  (chunk-contents (gethash curr-chunk-name *chunk-hash-table*)))

(defun view-all-chunks ()
  (maphash #'(lambda (k v) (format t "~a => ~a~%" k v))
*chunk-hash-table*))

(defun check-for-referenced-chunk (inputstring startpos)
   (let ((pos1 (search refstartchars inputstring :start2 startpos)))
     (let ((pos2 (if pos1 (search refendchars inputstring :start2
pos1))))
       (if (and pos1 pos2)
           (progn
           (if (search (string #\Newline) inputstring :start2 pos1 
                                                      :end2 pos2)
             (check-for-referenced-chunk inputstring 
                   (+(search (string #\Newline) inputstring :start2
pos1
                                                            :end2 pos2)
1) )
             (progn
               (let ((middlestring (subseq inputstring 
                                           (+ pos1 (length
refstartchars)) 
                                           pos2)))
                 (if (gethash middlestring *chunk-hash-table*)
                     (progn
                       (setf inputstring 
                             (concatenate 'string
                                          (subseq inputstring 0 pos1)
                                          (get-chunk-contents
middlestring)
                                          (subseq inputstring 
                                                  (+ pos2 (length
refendchars)))))
                       (check-for-referenced-chunk inputstring pos1))
                     (error  "~S was not found in hash table."
middlestring))))))
           inputstring))))

(defun check-for-newline-in-name (endofname pamphletfile)
   (let ((newlinepos (search (string #\Newline) pamphletfile :end2
endofname :from-end t))
         (startcharspos (search startchars pamphletfile :end2 endofname
:from-end t)))
     (if newlinepos
         (if (> newlinepos startcharspos) t))))

(defun find-next-chunk (startingpoint pamphletfile)
  (let ((endofname  (search endchars pamphletfile :start2
startingpoint))
        (startofname) (startofbody) (endofbody))
    (if endofname
         (if (check-for-newline-in-name endofname pamphletfile)
             (find-next-chunk (+ endofname (length endchars)) pamphletfile)
           (progn
             (setf startofname (+ (length startchars) (search startchars
pamphletfile :end2 endofname :from-end t)))
             (setf startofbody (+ (length endchars) endofname 1))
             (setf endofbody (+ 1 (search (concatenate 'string (string
#\Newline) endchunkchars) pamphletfile :start2 endofname)))
             (if (and startofname endofname startofbody endofbody) 
                 (list startofname endofname startofbody endofbody)))))))

(defun file-to-string (filename)
  (let ((openfile (open filename :if-does-not-exist nil)))
  (let ((fileasstring (make-array (file-length openfile) :element-type
'character :fill-pointer t)))
    (setf (fill-pointer fileasstring) (read-sequence fileasstring
openfile))
    (close openfile)
    fileasstring)))

(defun load-pamphlet-file (filename)
  (let ((pamphletfile (file-to-string filename)))
    (let ((checkedlength 0)
          (totallength (length pamphletfile))
          (chunkpositions (find-next-chunk 0 pamphletfile)))
     (if chunkpositions
         (progn
           (do ()
               ((> checkedlength totallength))
             (progn 
               (make-new-chunk (subseq pamphletfile (first chunkpositions)
(second chunkpositions))
                               (subseq pamphletfile (third chunkpositions) 
(fourth
chunkpositions)))
               (setf pamphletfile (subseq pamphletfile (fourth
chunkpositions)))
               (setf chunkpositions (find-next-chunk 0 pamphletfile))
               (if (not chunkpositions) (setf checkedlength (+ 1
totallength)))))
           )
         (error "No code chunks found.  Perhaps delimiters are
incorrect?")))))

(defun write-output-file (filename chunkname)
  (let ((outputstream (open filename :direction :output :if-exists
:supersede)))
    (write-string (check-for-referenced-chunk 
                   (get-chunk-contents chunkname) 0) outputstream)
    (close outputstream)))

(defun notangle (fileinname fileoutname &optional (chunkname "*"))
  (clrhash *chunk-hash-table*)
  (load-pamphlet-file fileinname)
  (write-output-file fileoutname chunkname)
  (clrhash *chunk-hash-table*))



 
____________________________________________________________________________________
Sucker-punch spam with award-winning protection. 
Try the free Yahoo! Mail Beta.
http://advision.webevents.yahoo.com/mailbeta/features_spam.html