From 9d75ae6b1fa8a08065d698e3b234d46761425134 Mon Sep 17 00:00:00 2001 From: erana Date: Wed, 25 Jan 2012 21:17:51 +0900 Subject: [PATCH] scganadu reinit --- scsh/scganadu/AUTHORS | 1 + scsh/scganadu/BLURB | 1 + scsh/scganadu/NEWS | 2 + scsh/scganadu/README | 6 + scsh/scganadu/b-tree.scm | 222 +++++++++++++++++++++++++++++++++ scsh/scganadu/load.scm | 36 ++++++ scsh/scganadu/packages.scm | 9 ++ scsh/scganadu/pkg-def.scm | 15 +++ scsh/scganadu/scganadu.scm | 76 +++++++++++ scsh/scganadu/scganaduutil.scm | 92 ++++++++++++++ scsh/scganadu/xml-tree.scm | 41 ++++++ scsh/scganadu/xml.scm | 57 +++++++++ 12 files changed, 558 insertions(+) create mode 100644 scsh/scganadu/AUTHORS create mode 100644 scsh/scganadu/BLURB create mode 100644 scsh/scganadu/NEWS create mode 100644 scsh/scganadu/README create mode 100644 scsh/scganadu/b-tree.scm create mode 100644 scsh/scganadu/load.scm create mode 100644 scsh/scganadu/packages.scm create mode 100644 scsh/scganadu/pkg-def.scm create mode 100644 scsh/scganadu/scganadu.scm create mode 100644 scsh/scganadu/scganaduutil.scm create mode 100644 scsh/scganadu/xml-tree.scm create mode 100644 scsh/scganadu/xml.scm diff --git a/scsh/scganadu/AUTHORS b/scsh/scganadu/AUTHORS new file mode 100644 index 0000000..c2430eb --- /dev/null +++ b/scsh/scganadu/AUTHORS @@ -0,0 +1 @@ +Copyright (C) 2011-2012 Johan Ceuppens diff --git a/scsh/scganadu/BLURB b/scsh/scganadu/BLURB new file mode 100644 index 0000000..9452aba --- /dev/null +++ b/scsh/scganadu/BLURB @@ -0,0 +1 @@ +scganadu : file system tools diff --git a/scsh/scganadu/NEWS b/scsh/scganadu/NEWS new file mode 100644 index 0000000..da41d2c --- /dev/null +++ b/scsh/scganadu/NEWS @@ -0,0 +1,2 @@ +version 0.1 +* preliminary methods diff --git a/scsh/scganadu/README b/scsh/scganadu/README new file mode 100644 index 0000000..9a9fe70 --- /dev/null +++ b/scsh/scganadu/README @@ -0,0 +1,6 @@ +This is a scganadu system. + +ideas/TODO: + +. libaa desktop publishing +. xml & svg (use autoprogramming for a scheme version) diff --git a/scsh/scganadu/b-tree.scm b/scsh/scganadu/b-tree.scm new file mode 100644 index 0000000..02e92db --- /dev/null +++ b/scsh/scganadu/b-tree.scm @@ -0,0 +1,222 @@ +;;; 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-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 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)) diff --git a/scsh/scganadu/load.scm b/scsh/scganadu/load.scm new file mode 100644 index 0000000..ac1621a --- /dev/null +++ b/scsh/scganadu/load.scm @@ -0,0 +1,36 @@ +;;; 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))) + diff --git a/scsh/scganadu/packages.scm b/scsh/scganadu/packages.scm new file mode 100644 index 0000000..5d907c9 --- /dev/null +++ b/scsh/scganadu/packages.scm @@ -0,0 +1,9 @@ +(define-interface scganadu-interface + (export + make-scganadu)) + +(define-structure scganadu + scgame-interface + (open scheme) + (files load scganadu scganaduutil)) + diff --git a/scsh/scganadu/pkg-def.scm b/scsh/scganadu/pkg-def.scm new file mode 100644 index 0000000..9f191cc --- /dev/null +++ b/scsh/scganadu/pkg-def.scm @@ -0,0 +1,15 @@ +(define-package "scganadu" + (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 "load.scm" 'scheme) + (install-file "scganadauutil.scm" 'scheme) + (install-file "scganadu.scm" 'scheme)) diff --git a/scsh/scganadu/scganadu.scm b/scsh/scganadu/scganadu.scm new file mode 100644 index 0000000..42c0fb3 --- /dev/null +++ b/scsh/scganadu/scganadu.scm @@ -0,0 +1,76 @@ +;;; 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 + "")))) + + (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 + ""))))) + + (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)) + + diff --git a/scsh/scganadu/scganaduutil.scm b/scsh/scganadu/scganaduutil.scm new file mode 100644 index 0000000..9a55432 --- /dev/null +++ b/scsh/scganadu/scganaduutil.scm @@ -0,0 +1,92 @@ +;;; 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 "" "" "" "")) + (*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"))))) + diff --git a/scsh/scganadu/xml-tree.scm b/scsh/scganadu/xml-tree.scm new file mode 100644 index 0000000..a9b23ed --- /dev/null +++ b/scsh/scganadu/xml-tree.scm @@ -0,0 +1,41 @@ +;;; 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)) diff --git a/scsh/scganadu/xml.scm b/scsh/scganadu/xml.scm new file mode 100644 index 0000000..a7c5b7d --- /dev/null +++ b/scsh/scganadu/xml.scm @@ -0,0 +1,57 @@ +;;; 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))) +