removing xanadu
This commit is contained in:
erana
parent
1de88dda31
commit
3007b888b3
|
|
@ -1 +0,0 @@
|
|||
Copyright (C) 2011-2012 Johan Ceuppens
|
||||
|
|
@ -1 +0,0 @@
|
|||
xanadu : Xanadu file system
|
||||
|
|
@ -1,2 +0,0 @@
|
|||
version 0.1
|
||||
* preliminary methods
|
||||
|
|
@ -1,6 +0,0 @@
|
|||
This is a xanadu system.
|
||||
|
||||
ideas/TODO:
|
||||
|
||||
. libaa desktop publishing
|
||||
. xml & svg (use autoprogramming for a scheme version)
|
||||
|
|
@ -1,222 +0,0 @@
|
|||
;;; b-tree.scm - a B-tree for Xanadu
|
||||
;;;
|
||||
;;; Copyright (c) 2012 Johan Ceuppens
|
||||
;;;
|
||||
;;; All rights reserved.
|
||||
;;;
|
||||
;;; Redistribution and use in source and binary forms, with or without
|
||||
;;; modification, are permitted provided that the following conditions
|
||||
;;; are met:
|
||||
;;; 1. Redistributions of source code must retain the above copyright
|
||||
;;; notice, this list of conditions and the following disclaimer.
|
||||
;;; 2. Redistributions in binary form must reproduce the above copyright
|
||||
;;; notice, this list of conditions and the following disclaimer in the
|
||||
;;; documentation and/or other materials provided with the distribution.
|
||||
;;; 3. The name of the authors may not be used to endorse or promote products
|
||||
;;; derived from this software without specific prior written permission.
|
||||
;;;
|
||||
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR
|
||||
;;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
|
||||
;;; OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
|
||||
;;; IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT,
|
||||
;;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
|
||||
;;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
|
||||
;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
|
||||
;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
|
||||
;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
|
||||
;;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
|
||||
;; FIXMES
|
||||
;; copy vector nodes into n-ary vectors (from median splitted vecs)
|
||||
|
||||
(define (make-b-tree-node l r)
|
||||
(let ((data #f)
|
||||
(left l)
|
||||
(right r))
|
||||
|
||||
(define (get-data)
|
||||
data)
|
||||
|
||||
(define (set-data! value)
|
||||
(set! data value))
|
||||
|
||||
(define (set-left-with-index! i value)
|
||||
(cond ((not left)
|
||||
(display "b-tree : no left node vector.")
|
||||
#f)
|
||||
(else (vector-set! left i value))))
|
||||
|
||||
(define (set-right-with-index! i value)
|
||||
(cond ((not right)
|
||||
(display "b-tree : no right node vector")
|
||||
#f)
|
||||
(else (vector-set! right i value))))
|
||||
|
||||
(define (get-left)
|
||||
left)
|
||||
|
||||
(define (get-right)
|
||||
right)
|
||||
|
||||
(define (dispatch msg)
|
||||
(lambda (msg)
|
||||
(cond ((eq? msg 'get-left)
|
||||
get-left)
|
||||
((eq? msg 'get-right)
|
||||
get-right)
|
||||
((eq? msg 'set-left-with-index!)
|
||||
set-left-with-index!)
|
||||
((eq? msg 'set-right-with-index!)
|
||||
set-right-with-index!)
|
||||
((eq? msg 'get-data)
|
||||
get-data)
|
||||
((eq? msg 'set-data!)
|
||||
set-data!)
|
||||
(else (display "b-tree-node : message not understood")(newline)))))
|
||||
dispatch))
|
||||
|
||||
(define (make-b-tree n-ary)
|
||||
(let ((*tree (make-b-tree-node
|
||||
(make-vector n-ary (make-b-tree-node #f #f))
|
||||
(make-vector n-ary (make-b-tree-node #f #f)))))
|
||||
|
||||
(define (vector-median j v)
|
||||
(let ((len (vector-length v)))
|
||||
(let ((retl (make-vector (- j 1) (make-b-tree-node #f #f)))
|
||||
(retr (make-vector (- len (+ j 1)) (make-b-tree-node #f #f))))
|
||||
(do ((i 0 (+ i 1)))
|
||||
((= i len)(list retl retr))
|
||||
(vector-set! retl i (vector-ref v i))
|
||||
(vector-set! retr (- len (+ i 1)) (vector-ref v (- len (+ i 1))))
|
||||
))))
|
||||
|
||||
;;FIXME
|
||||
(define (search-rec str tree side-string) ;; root param in b-treenode
|
||||
(let* ((side-tree (tree side-string))
|
||||
(len (vector-length side-tree)))
|
||||
(do ((i 0 (+ i 1)))
|
||||
((let ((side-tree-el-first (vector-ref side-tree i)))
|
||||
(cond ((>= i len);;last node
|
||||
(do ((j 0 (+ j 1)))
|
||||
((= j len) 0)
|
||||
(search-rec str (vector-ref side-tree j) 'get-left)
|
||||
(search-rec str (vector-ref side-tree j) 'get-right)
|
||||
))
|
||||
((let ((side-tree-el-second (vector-ref side-tree (+ i 1))))
|
||||
(and (string<? str
|
||||
((side-tree-el-first 'get-data)))
|
||||
(string>? str
|
||||
((side-tree-el-second 'get-data))))
|
||||
(display "b-tree search : node not found in tree.") 0))
|
||||
((string=? str ((side-tree-el-first 'get-data)))
|
||||
(display "b-tree search : string found in tree.") str)
|
||||
(else (display "b-tree : never reached."))))))))
|
||||
|
||||
(define (search str)
|
||||
(search-rec str *tree 'get-left)
|
||||
(search-rec str *tree 'get-right))
|
||||
|
||||
;;FIXME
|
||||
(define (dump-rec tree)
|
||||
(if (not (tree 'get-left))
|
||||
0
|
||||
(let ((len (vector-length (tree 'get-left))))
|
||||
(do ((i 0 (+ i 1)))
|
||||
((>= i len) 0)
|
||||
(display (((vector-ref (tree 'get-left) i)'get-data)))
|
||||
(dump-rec (vector-ref (tree 'get-left) i))
|
||||
)))
|
||||
(if (not (tree 'get-right))
|
||||
0
|
||||
(let ((len (vector-length (tree 'get-right))))
|
||||
(do ((i 0 (+ i 1)))
|
||||
((>= i len) 0)
|
||||
(dump-rec (vector-ref (tree 'get-right) i))
|
||||
))))
|
||||
|
||||
(define (dump)
|
||||
(dump-rec *tree))
|
||||
|
||||
(define (add-rec str tree) ;; root param in b-treenode ;; refactor call-with-values
|
||||
|
||||
(let ((lefttree (tree 'get-left));;FIXME ()
|
||||
(righttree (tree 'get-right)))
|
||||
;;len (vector-length ((tree 'get-left)))))
|
||||
;;(call-with-values
|
||||
;; (lambda () (values lefttree righttree))
|
||||
;; (lambda (lefttree righttree)
|
||||
(add-rec-side-tree str lefttree)
|
||||
(add-rec-side-tree str righttree)
|
||||
;; ))
|
||||
))
|
||||
|
||||
(define (add-rec-side-tree str side-tree)
|
||||
(do ((i 0 (+ i 1)))
|
||||
((cond ((not side-tree)
|
||||
#f)
|
||||
((= i (vector-length side-tree))
|
||||
(do ((i 0 (+ i 1)))
|
||||
((= i (vector-length side-tree))0)
|
||||
(let ((side-tree-node (vector-ref i side-tree)))
|
||||
(cond ((not (not side-tree-node))
|
||||
#f)
|
||||
(else (add-rec str side-tree-node)))));;NOTE add-rec not the other add-rec
|
||||
)
|
||||
((let* ((data (((vector-ref side-tree i) 'get-data)))
|
||||
(left-and-right (vector-median i side-tree));;FIXME right also descend
|
||||
(new-node (make-b-tree-node
|
||||
(car left-and-right)
|
||||
(cadr left-and-right))));;FIXME lenght mustbe n-ary
|
||||
|
||||
(or (not data)
|
||||
(and data (string? data)(string=? data "")))
|
||||
((new-node 'set-data!) str)
|
||||
;;((side-tree 'set-left-with-index!) i new-node)
|
||||
(vector-set! side-tree i new-node)
|
||||
(set! i (vector-length side-tree))))
|
||||
|
||||
((let ((data (((vector-ref side-tree i) 'get-data)))
|
||||
(data2 (((vector-ref side-tree (if (< (- i 1)(vector-length side-tree))
|
||||
(+ i 1)
|
||||
i)
|
||||
) 'get-data))))
|
||||
(or ;;(and (string=?)
|
||||
;; (string>? str data))
|
||||
(and (string? data)
|
||||
(string=? data ""))
|
||||
(and (string? data)
|
||||
(string? data2)
|
||||
(string<? str data)
|
||||
(string>? str data2)));;FIXME data2!
|
||||
(let ((left-and-right (vector-median i side-tree)))
|
||||
(let ((new-node (make-b-tree-node (car left-and-right) (cadr left-and-right))))
|
||||
((new-node 'set-data!) str)
|
||||
(vector-set! side-tree i new-node)
|
||||
))))
|
||||
((let ((data (((vector-ref side-tree i) 'get-data))))
|
||||
(string=? data str) ;;NOTE duplicates possible
|
||||
(display "b-tree - node already exists.")
|
||||
0))
|
||||
(else (display "b-tree - add - never reached.")))))
|
||||
)
|
||||
|
||||
|
||||
|
||||
(define (add str)
|
||||
(add-rec str *tree)
|
||||
)
|
||||
|
||||
(define (dispatch msg)
|
||||
(cond ((eq? msg 'add) add)
|
||||
((eq? msg 'search) search)
|
||||
((eq? msg 'dump) dump)
|
||||
(else (display "b-tree : message not understood.")(newline))))
|
||||
dispatch))
|
||||
|
||||
;; test program
|
||||
;;(define bt (make-b-tree 2))
|
||||
;;((bt 'add)"abc")
|
||||
;;((bt 'add)"def")
|
||||
;;((bt 'add)"hij")
|
||||
;;((bt 'search)"abc")
|
||||
;;((bt 'dump))
|
||||
|
|
@ -1,36 +0,0 @@
|
|||
;;; load.scm - a Xanadu file system (until desktop publishing)
|
||||
;;;
|
||||
;;; Copyright (c) 2011-2012 Johan Ceuppens
|
||||
;;;
|
||||
;;; All rights reserved.
|
||||
;;;
|
||||
;;; Redistribution and use in source and binary forms, with or without
|
||||
;;; modification, are permitted provided that the following conditions
|
||||
;;; are met:
|
||||
;;; 1. Redistributions of source code must retain the above copyright
|
||||
;;; notice, this list of conditions and the following disclaimer.
|
||||
;;; 2. Redistributions in binary form must reproduce the above copyright
|
||||
;;; notice, this list of conditions and the following disclaimer in the
|
||||
;;; documentation and/or other materials provided with the distribution.
|
||||
;;; 3. The name of the authors may not be used to endorse or promote products
|
||||
;;; derived from this software without specific prior written permission.
|
||||
;;;
|
||||
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR
|
||||
;;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
|
||||
;;; OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
|
||||
;;; IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT,
|
||||
;;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
|
||||
;;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
|
||||
;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
|
||||
;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
|
||||
;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
|
||||
;;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
|
||||
(load "scganadu.scm")
|
||||
|
||||
;; interface
|
||||
|
||||
(define X (make-scganadu))
|
||||
(define (scganadu-add-file X filename) ((X 'add-file) filename))
|
||||
(define (scganadu-attach-to-file! X filename) ((X 'attach-to-file! filename)))
|
||||
|
||||
|
|
@ -1,9 +0,0 @@
|
|||
(define-interface scgame-interface
|
||||
(export
|
||||
make-scganadu))
|
||||
|
||||
(define-structure scgame
|
||||
scgame-interface
|
||||
(open scheme)
|
||||
(files load scganadu scganaduutil))
|
||||
|
||||
|
|
@ -1,14 +0,0 @@
|
|||
(define-package "xanadu"
|
||||
(0 1)
|
||||
((install-lib-version (1 3 0)))
|
||||
(write-to-load-script
|
||||
`((config)
|
||||
(load ,(absolute-file-name "packages.scm"
|
||||
(get-directory 'scheme #f)))))
|
||||
(install-file "README" 'doc)
|
||||
(install-file "NEWS" 'doc)
|
||||
(install-string (COPYING) "COPYING" 'doc)
|
||||
(install-file "packages.scm" 'scheme)
|
||||
(install-file "config.scm" 'scheme)
|
||||
(install-file "scganadauutil.scm" 'scheme)
|
||||
(install-file "scganadu.scm" 'scheme))
|
||||
|
|
@ -1,76 +0,0 @@
|
|||
;;; scganadu.scm - a Xanadu file system (until desktop publishing)
|
||||
;;;
|
||||
;;; Copyright (c) 2011-2012 Johan Ceuppens
|
||||
;;;
|
||||
;;; All rights reserved.
|
||||
;;;
|
||||
;;; Redistribution and use in source and binary forms, with or without
|
||||
;;; modification, are permitted provided that the following conditions
|
||||
;;; are met:
|
||||
;;; 1. Redistributions of source code must retain the above copyright
|
||||
;;; notice, this list of conditions and the following disclaimer.
|
||||
;;; 2. Redistributions in binary form must reproduce the above copyright
|
||||
;;; notice, this list of conditions and the following disclaimer in the
|
||||
;;; documentation and/or other materials provided with the distribution.
|
||||
;;; 3. The name of the authors may not be used to endorse or promote products
|
||||
;;; derived from this software without specific prior written permission.
|
||||
;;;
|
||||
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR
|
||||
;;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
|
||||
;;; OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
|
||||
;;; IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT,
|
||||
;;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
|
||||
;;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
|
||||
;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
|
||||
;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
|
||||
;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
|
||||
;;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
|
||||
;; This code fabricates xanadu hypertext files to attach
|
||||
;; to xanandu objects or use as metafiles
|
||||
|
||||
(load "scganaduutil.scm")
|
||||
|
||||
(define (make-scganadu)
|
||||
(let ((record (delay #f)))
|
||||
|
||||
(define (add-file filename)
|
||||
(let ((displayproc (write (((FILE-MAKER-unit (force record)) 'get-post-html)
|
||||
(string-append "<filename>"
|
||||
filename
|
||||
"</filename>"))))
|
||||
|
||||
(with-output-to-file (string-append "." filename ".scganadu") displayproc)
|
||||
)))
|
||||
|
||||
(define (attach-to-file! filename)
|
||||
(let ((displayproc (write (((FILE-MAKER-unit (force record)) 'get-post-html)
|
||||
(string-append "<filename>"
|
||||
filename
|
||||
"</filename>")))))
|
||||
|
||||
(with-output-to-file filename displayproc)
|
||||
))
|
||||
|
||||
(define (dispatch msg)
|
||||
(lambda (msg)
|
||||
(cond ((eq? msg 'add-file)add-file)
|
||||
((eq? msg 'attach-to-file!)attach-to-file!)
|
||||
(else (aspecterror) (display "make-scganadu")))))
|
||||
|
||||
|
||||
(define :scganadu-record
|
||||
(make-record-type 'scganadu-record
|
||||
'(FILE-MAKER make-scganadu)))
|
||||
(define make-scganadu-record
|
||||
(record-constructor :scganadu-record
|
||||
'(FILE-MAKER make-scganadu)))
|
||||
(define FILE-MAKER-unit (record-accessor :scganadu-record 'FILE-MAKER))
|
||||
(define make-scganadu-unit (record-accessor :scganadu-record 'make-scganadu))
|
||||
(define make-scganadu-record
|
||||
(delay (make-copy-of-document))
|
||||
(delay (make-cell dispatch)))
|
||||
(set! record make-scganadu-record)
|
||||
dispatch))
|
||||
|
||||
|
||||
|
|
@ -1,92 +0,0 @@
|
|||
;;; scganaduutil.scm - a scheme Xanadu utility
|
||||
;;;
|
||||
;;; Copyright (c) 2011-2012 Johan Ceuppens
|
||||
;;;
|
||||
;;; All rights reserved.
|
||||
;;;
|
||||
;;; Redistribution and use in source and binary forms, with or without
|
||||
;;; modification, are permitted provided that the following conditions
|
||||
;;; are met:
|
||||
;;; 1. Redistributions of source code must retain the above copyright
|
||||
;;; notice, this list of conditions and the following disclaimer.
|
||||
;;; 2. Redistributions in binary form must reproduce the above copyright
|
||||
;;; notice, this list of conditions and the following disclaimer in the
|
||||
;;; documentation and/or other materials provided with the distribution.
|
||||
;;; 3. The name of the authors may not be used to endorse or promote products
|
||||
;;; derived from this software without specific prior written permission.
|
||||
;;;
|
||||
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR
|
||||
;;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
|
||||
;;; OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
|
||||
;;; IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT,
|
||||
;;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
|
||||
;;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
|
||||
;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
|
||||
;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
|
||||
;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
|
||||
;;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
|
||||
(define (aspecterror)
|
||||
(display "::error:: Message not understood."))
|
||||
|
||||
(define (aspectmsg)
|
||||
(display "::message:: "))
|
||||
|
||||
;; FIX : use scsh regexp instead of these following 2 functions
|
||||
|
||||
(define (string-cat s j)
|
||||
(if (< j (string-length s))
|
||||
(begin
|
||||
(display j)
|
||||
(string-append (string (string-ref s j)) (string-cat s (+ j 1)))
|
||||
)
|
||||
""))
|
||||
|
||||
(define (substring? needle haystack j)
|
||||
;; (define (max? s1 s2 j)
|
||||
(if (and (string? haystack)(string? needle))
|
||||
(let ((hs (string-cat haystack j)))
|
||||
(if (string<=? needle hs)
|
||||
hs
|
||||
#f))
|
||||
#f))
|
||||
|
||||
|
||||
(define (make-copy-of-document)
|
||||
(let ((*XMLOPENDATA (list "<scganadu>" "<audio>" "<image>"))
|
||||
(*XMLCLOSEDATA (list "</scganadu>" "</audio>" "</image>"))
|
||||
(*scganadutag! car)
|
||||
(*audiotag! cadr)
|
||||
(*imagetag! caadr)
|
||||
)
|
||||
|
||||
(define (get-open-xml tag)
|
||||
(tag *XMLOPENDATA))
|
||||
(define (get-close-xml tag)
|
||||
(tag *XMLCLOSEDATA))
|
||||
|
||||
(define (get-copyright)
|
||||
"Copyright (C) unknown by SCGanadu."))
|
||||
|
||||
(define (get-post hypertext)
|
||||
(get-post-html hypertext))
|
||||
(define (get-post-html hypertext)
|
||||
(string-append (get-open-xml scganadutag!) hypertext (get-open-xml scganadutag!))
|
||||
(define (get-post-sound hypertext2)
|
||||
(get-post-html (string (get-open-xml audiotag!) hypertext2 (get-close-xml audiotag!))))
|
||||
(define (get-post-image hypertext3)
|
||||
(get-post-html (string (get-open-xml imagetag!) hypertext3 (get-close-xml imagetag!))))
|
||||
|
||||
(lambda (msg)
|
||||
(cond ((eq? msg 'get-copyright)
|
||||
get-copyright)
|
||||
((eq? msg 'get-post-sound)
|
||||
get-post-sound)
|
||||
((eq? msg 'get-post-image)
|
||||
get-post-image)
|
||||
((eq? msg 'get-post-scganadu)
|
||||
get-post-scganadu)
|
||||
((eq? msg 'get-post)
|
||||
get-post)
|
||||
(else (aspecterror) (display "make-copy-of-document")))))
|
||||
|
||||
|
|
@ -1,41 +0,0 @@
|
|||
;;; xml-tree.scm - a xml tree for Xanadu
|
||||
;;;
|
||||
;;; Copyright (c) 2012 Johan Ceuppens
|
||||
;;;
|
||||
;;; All rights reserved.
|
||||
;;;
|
||||
;;; Redistribution and use in source and binary forms, with or without
|
||||
;;; modification, are permitted provided that the following conditions
|
||||
;;; are met:
|
||||
;;; 1. Redistributions of source code must retain the above copyright
|
||||
;;; notice, this list of conditions and the following disclaimer.
|
||||
;;; 2. Redistributions in binary form must reproduce the above copyright
|
||||
;;; notice, this list of conditions and the following disclaimer in the
|
||||
;;; documentation and/or other materials provided with the distribution.
|
||||
;;; 3. The name of the authors may not be used to endorse or promote products
|
||||
;;; derived from this software without specific prior written permission.
|
||||
;;;
|
||||
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR
|
||||
;;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
|
||||
;;; OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
|
||||
;;; IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT,
|
||||
;;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
|
||||
;;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
|
||||
;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
|
||||
;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
|
||||
;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
|
||||
;;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
|
||||
(load "b-tree.scm")
|
||||
(load "xml.scm")
|
||||
|
||||
(define (make-xml-tree n-ary)
|
||||
(let ((*bt (make-b-tree n-ary)))
|
||||
|
||||
(define (add-tag tag)
|
||||
0)
|
||||
|
||||
(define (dispatch msg)
|
||||
(cond ((eq? msg 'add-tag)add-tag)
|
||||
(else (*bt msg))))
|
||||
dispatch))
|
||||
|
|
@ -1,57 +0,0 @@
|
|||
;;; xml.scm - a simple scheme XML library
|
||||
;;;
|
||||
;;; Copyright (c) 2012 Johan Ceuppens
|
||||
;;;
|
||||
;;; All rights reserved.
|
||||
;;;
|
||||
;;; Redistribution and use in source and binary forms, with or without
|
||||
;;; modification, are permitted provided that the following conditions
|
||||
;;; are met:
|
||||
;;; 1. Redistributions of source code must retain the above copyright
|
||||
;;; notice, this list of conditions and the following disclaimer.
|
||||
;;; 2. Redistributions in binary form must reproduce the above copyright
|
||||
;;; notice, this list of conditions and the following disclaimer in the
|
||||
;;; documentation and/or other materials provided with the distribution.
|
||||
;;; 3. The name of the authors may not be used to endorse or promote products
|
||||
;;; derived from this software without specific prior written permission.
|
||||
;;;
|
||||
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR
|
||||
;;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
|
||||
;;; OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
|
||||
;;; IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT,
|
||||
;;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
|
||||
;;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
|
||||
;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
|
||||
;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
|
||||
;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
|
||||
;;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
|
||||
|
||||
(define (xml-load-tree! filename)
|
||||
(let ((in (open-input-file filename))
|
||||
(contents ""))
|
||||
|
||||
(define (tagify! c tagged)
|
||||
(cond ((> tagged 0) "")
|
||||
((= tagged 0) (if (eq? c #\>) "" (string c)))
|
||||
;; FIXME make node, descend one level
|
||||
(else "")))
|
||||
|
||||
(define (xml-read-in-file contents)
|
||||
(let ((tagged 0))
|
||||
(do ((c (read-char in) (read-char in)))
|
||||
((eof-object? c) contents)
|
||||
(cond ((and (= tagged 0)(eq? c #\<))
|
||||
(set! tagged (+ tagged 1)))
|
||||
((and (> tagged 0)(eq? c #\<))
|
||||
(set! tagged (+ tagged 1)))
|
||||
((and (= tagged 0)(eq? c #\>))
|
||||
(set! tagged (- tagged 1)))
|
||||
((and (> tagged 0)(eq? c #\>))
|
||||
(set! tagged (- tagged 1)))
|
||||
((< tagged 0)
|
||||
(display "xml : bad xml file - broken tags.")(newline)
|
||||
(set! tagged 0))
|
||||
)
|
||||
(set! contents (string-append contents (tagify! c tagged))))))
|
||||
(xml-read-in-file contents)))
|
||||
|
||||
Loading…
Reference in New Issue