From 51a96d60fd5dc9748ee57798b8e8ae74298073fd Mon Sep 17 00:00:00 2001 From: erana Date: Fri, 20 Jan 2012 21:59:49 +0900 Subject: [PATCH] xanadu directory --- scsh/xanadu/AUTHORS | 1 + scsh/xanadu/BLURB | 1 + scsh/xanadu/NEWS | 2 + scsh/xanadu/README | 1 + scsh/xanadu/scganadu.scm | 82 ++++++++++++++++++++++++++++++++ scsh/xanadu/scganaduutil.scm | 92 ++++++++++++++++++++++++++++++++++++ 6 files changed, 179 insertions(+) create mode 100644 scsh/xanadu/AUTHORS create mode 100644 scsh/xanadu/BLURB create mode 100644 scsh/xanadu/NEWS create mode 100644 scsh/xanadu/README create mode 100644 scsh/xanadu/scganadu.scm create mode 100644 scsh/xanadu/scganaduutil.scm diff --git a/scsh/xanadu/AUTHORS b/scsh/xanadu/AUTHORS new file mode 100644 index 0000000..c2430eb --- /dev/null +++ b/scsh/xanadu/AUTHORS @@ -0,0 +1 @@ +Copyright (C) 2011-2012 Johan Ceuppens diff --git a/scsh/xanadu/BLURB b/scsh/xanadu/BLURB new file mode 100644 index 0000000..26ba26c --- /dev/null +++ b/scsh/xanadu/BLURB @@ -0,0 +1 @@ +xanadu : Xanadu file system diff --git a/scsh/xanadu/NEWS b/scsh/xanadu/NEWS new file mode 100644 index 0000000..da41d2c --- /dev/null +++ b/scsh/xanadu/NEWS @@ -0,0 +1,2 @@ +version 0.1 +* preliminary methods diff --git a/scsh/xanadu/README b/scsh/xanadu/README new file mode 100644 index 0000000..1f70c91 --- /dev/null +++ b/scsh/xanadu/README @@ -0,0 +1 @@ +This is a xanadu system. diff --git a/scsh/xanadu/scganadu.scm b/scsh/xanadu/scganadu.scm new file mode 100644 index 0000000..9e7939a --- /dev/null +++ b/scsh/xanadu/scganadu.scm @@ -0,0 +1,82 @@ +;;; 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 "scgameutil.scm") +(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)) + + +;; interface + +(define scganadu (make-scganadu)) +;; FIXME (define X (make-scganadu1)) +(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/xanadu/scganaduutil.scm b/scsh/xanadu/scganaduutil.scm new file mode 100644 index 0000000..9a55432 --- /dev/null +++ b/scsh/xanadu/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"))))) +