diff --git a/scsh/scgame/AUTHORS b/scsh/scgame/AUTHORS
new file mode 100644
index 0000000..c2430eb
--- /dev/null
+++ b/scsh/scgame/AUTHORS
@@ -0,0 +1 @@
+Copyright (C) 2011-2012 Johan Ceuppens
diff --git a/scsh/scgame/BLURB b/scsh/scgame/BLURB
new file mode 100644
index 0000000..ffaf070
--- /dev/null
+++ b/scsh/scgame/BLURB
@@ -0,0 +1 @@
+scgame : a Carbon library (drawing and widgets)
diff --git a/scsh/scgame/NEWS b/scsh/scgame/NEWS
new file mode 100644
index 0000000..7af6637
--- /dev/null
+++ b/scsh/scgame/NEWS
@@ -0,0 +1,2 @@
+version 0.1
+* line drawing algorithm and xanadu file system
diff --git a/scsh/scgame/README b/scsh/scgame/README
new file mode 100644
index 0000000..03e0fcc
--- /dev/null
+++ b/scsh/scgame/README
@@ -0,0 +1 @@
+scgame is a drawing package and should be useful to make widgets
diff --git a/scsh/scgame/packages.scm b/scsh/scgame/packages.scm
new file mode 100644
index 0000000..648a4e6
--- /dev/null
+++ b/scsh/scgame/packages.scm
@@ -0,0 +1,9 @@
+(define-interface scgame-interface
+ (export
+ make-scgame))
+
+(define-structure scgame
+ scgame-interface
+ (open scheme)
+ (files scgame))
+
diff --git a/scsh/scgame/pkg-def.scm b/scsh/scgame/pkg-def.scm
new file mode 100644
index 0000000..a562ebb
--- /dev/null
+++ b/scsh/scgame/pkg-def.scm
@@ -0,0 +1,17 @@
+(define-package "scgame"
+ (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 "scgamedictionaries.scm" 'scheme)
+ (install-file "scgameutil.scm" 'scheme)
+ (install-file "scgamewidgets.scm" 'scheme)
+ (install-file "scganadu.scm" 'scheme)
+ (install-file "scganaduutil.scm" 'scheme)
+ (install-file "scgame.scm" 'scheme))
diff --git a/scsh/scgame/scgame.scm b/scsh/scgame/scgame.scm
new file mode 100644
index 0000000..f3f8524
--- /dev/null
+++ b/scsh/scgame/scgame.scm
@@ -0,0 +1,179 @@
+;;; scgame.scm - a scheme game library
+;;;
+;;; 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 "scgameutil.scm")
+(load "scgamedictionaries.scm")
+
+;; interface 1
+(define (make-scdraw1) (lambda (msg) (aspecterror)(display "make-scdraw1")))
+(define (make-scimage1) (lambda (msg) (aspecterror)(display "make-scimage1")))
+
+;; interface 2
+(define (coolness? x) (not (null? x))) ;; coolness
+
+(define (make-scdraw2)
+ (define (draw-line x0 y0 x1 y1 . w) ;; FIXME w == line width
+ (let ((width (if (coolness? w)(if (number? (car w)) (car w) 1))))
+ (display "FIX drawing line...")
+ ;;FIXME This should be Bresenham
+ (let ((steep (> (abs (- y1 y0))
+ (abs (- x1 x0))))
+ (swap (lambda (x y)
+ (list y x)))
+ (range (lambda (x y)
+ (let ((l '()))
+ (cond ((< x y)
+ (do ((i x (+ i 1)))
+ ((= x y) l)
+ (set! l (append l (list i)))))
+ ((< y x)
+ (do ((i y (+ i 1)))
+ ((= y x) l)
+ (set! l (append l (list i)))))
+ (else (display "range : x == y")
+ x)))))
+ )
+ (if steep
+ (let ((t (swap x0 y0))
+ (x0 (car t))
+ (y0 (cadr t)))
+ (let ((deltax (- x1 x0))
+ (deltay (abs (- y1 y0))))
+ (let ((error (/ delta 2))
+ (ystep 0)
+ (y y0))
+ (if (< y0 y1)
+ (+ ystep 1)
+ (- ystep 1)
+ (for-each (if steep
+ (putpixel y x 254)
+ (putpixel x y 254))
+
+ (set! error (- error deltay))
+ (if (< error 0)
+ (set! y (+ y ystep))
+ (set! error (+ error deltax)))
+ (range x0 x1))
+ ))))))))
+
+ (define (draw-lines l1 . w)
+ (display "FIX drawing lines...")
+ (for-each draw-line l1)
+ )
+
+ (lambda (msg)
+ (cond ((eq? msg 'draw-line)draw-line)
+ (else (aspecterror)(display "scdraw2"))))
+ ))
+
+
+;; color table out of xpm pre
+
+(define (make-color-table)
+ (let ((dict (make-dictionary)))
+ (define (add! key color)
+ (dictionary-add! dict key color))
+ (define (set! key color)
+ (dictionary-set! dict key color))
+ (lambda (msg)
+ (cond ((eq? msg 'add!) add!)
+ ((eq? msg 'set!) set!)
+ (else (dict msg))))
+ ))
+
+(define (make-scimage2)
+ (let ((*db (make-dictionary)))
+
+ ;; private methods
+
+ (define (load-xpm-image filename)
+ (let ((in (open-input-file filename))
+ (colorcharsdictionary (make-color-dictionary 8)) ;;
+ (colorcharstable (make-color-table))
+ )
+ (do ((str (read in) (read in)))
+ ((string<=? "{" str)#t))
+ (do ((chr (read-char in) (read-char in)))
+ ((eq? #\" chr)#t))
+ (let ((width (read in))
+ (height (read in))
+ (number-of-colors (read in))
+ )
+ (do ((chr (read-char in) (read-char in)))
+ ((eq? #\, chr)#t))
+ (do ((n1 number-of-colors (- n1 1)))
+ ((<= n1 0)#t)
+ (do ((chr (read-char in) (read-char in)))
+ ((eq? #\" chr)#t))
+ (let* ((colorchar (read-char in))
+ (colorcharnumber (string->number (string colorchar)))
+ )
+ ((colorchars 'add!) colorchar colorcharnumber) ;; FIXME color 255 (extra map-dict)
+ ))
+ ;;FIX
+ )))
+
+ ;; public methods
+
+ (define (load-image filename)
+ ;; FIXME read in xpm or png
+ (display "loading image...")
+ (cond ((string<=? ".xpm" filename)
+ (load-xpm-image filename)
+ )
+
+ (lambda (msg)
+ (cond ((eq? msg 'load-image)load-image)
+ (else (aspecterror)(display "scimage2"))))
+ ))
+
+;; Give a #t as arg and have a nice interface
+(define (make-scgame . tm)
+ (cond ((not (null? tm)
+ (let ((*scdraw (make-scdraw1))
+ (*scimage (make-scimage1))
+ )
+
+ (lambda (msg)
+ (cond ((do ((i 0 (+ i 1)))
+ ((substring? "draw-" msg i) (*scdraw msg))))
+ ((do ((i 0 (+ i 1)))
+ ((substring? "image-" msg i) (*scimage msg))))
+ (else (aspecterror)(display "scgame1"))
+ ))))
+ )
+ (else
+ (let ((*scdraw (make-scdraw2))
+ (*scimage (make-scimage2))
+ )
+
+ (lambda (msg)
+ (cond ((eq? msg 'draw-line) (*scdraw msg))
+ ((eq? msg 'draw-lines) (*scdraw msg))
+ (else (aspecterror)(display "scgame2"))))
+ ))))
diff --git a/scsh/scgame/scgamedictionaries.scm b/scsh/scgame/scgamedictionaries.scm
new file mode 100644
index 0000000..c54b7cc
--- /dev/null
+++ b/scsh/scgame/scgamedictionaries.scm
@@ -0,0 +1,276 @@
+;;; scgamedictionaries.scm - a scheme dictionary system for scgame
+;;;
+;;; 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.
+;; Dictionary ADT with ref,set!,add!,make public methods at the end
+
+(define (make-dictionary1)
+ ;; methods are FIFO (first fixed first out)
+ (let ((*dict '()))
+
+ (define (get key) ;; get key
+ (do ((l *dict (cdr l)))
+ ((eq? key (caar l))
+ (cadr l));;returns value
+ ))
+ (define (add key value)
+ (set! *dict (append *dict (list (list key value)))))
+
+ (define (set key value) ;; get key
+ (do ((l *dict (cdr l))
+ (res '() (append (list (car l) res))))
+ ((eq? key (caar l))
+ (set! (cadr res) value)
+ (set! *dict (append res (cdr l))))
+ ))
+
+
+ (lambda (msg)
+ (cond ((eq? msg 'get) get)
+ ((eq? msg 'set) set)
+ ((eq? msg 'add) add)
+ (else (aspecterror)(display "make-dictionary"))))
+ ))
+
+(define (make-dictionary) (make-dictionary1))
+(define (dictionary-ref dict key) ((dict 'get) key))
+(define (dictionary-set! dict key value) ((dict 'set) key value))
+(define (dictionary-add! dict key value) ((dict 'add) key value))
+
+;; color dictionary - for CSS colors use bpp set to 0
+;; helper functions
+
+(define (string->color str)
+ (let ((colornumber 0))
+ (do ((i 0 (+ i 1)))
+ ((< i (string-length str)) colornumber)
+ (let* ((c (string-ref str i))
+ (n (cond ((or (eq? c #\a)(eq? c #\A))
+ 10)
+ ((or (eq? c #\b)(eq? c #\B))
+ 11)
+ ((or (eq? c #\c)(eq? c #\C))
+ 12)
+ ((or (eq? c #\d)(eq? c #\D))
+ 13)
+ ((or (eq? c #\e)(eq? c #\E))
+ 14)
+ ((or (eq? c #\f)(eq? c #\F))
+ 15)
+ (else (string->number (string c))))))
+ (set! colornumber (+ (* n 16) colornumber))))))
+
+(define (little-endian->big-endian n)
+ (let ((str (string n))
+ (rets ""))
+ (do ((i (string-length str) (- i 1)))
+ ((<= i 0)
+ (string->number rets))
+ (set! rets (string
+ (bitwise-and
+ (string->number (* (expt 2 i)(string-ref str i)))
+ (string->number rets)))))
+ ))
+
+(define (big-endian->littleendian n)
+ (let ((str (string n))
+ (rets ""))
+ (do ((i 0 (+ i 1)))
+ ((>= i (string-length str))
+ (string->number rets))
+ (set! rets (string
+ (bitwise-and
+ (string->number (* (expt 2 i)(string-ref str i)))
+ (string->number rets)))))
+ ))
+
+
+(define (make-color-dictionary bpp)
+ (let ((dict (make-dictionary))
+ (pow (expt 2 bpp)))
+ (cond ((= pow 16) ;; 16 colors
+ (do ((i 0 (+ i 1)))
+ ((< i pow)
+ (dictionary-add! dict i i)))
+ (dictionary-add! dict 'black 0)
+
+ ;; ... FIXME fill in 4-bit colors
+ dict)
+ ((= pow 256) ;; 256 colors
+ (dictionary-add! dict 'black 0)
+ ;; ... FIXME fill in 8-bit colors
+ dict)
+ (else (display "color-dictionary : no or unsupported bit depth. Using CSS dictionary")
+ (dictionary-add! dict 'Black "000000")
+ (dictionary-add! dict 'Navy "000080")
+ (dictionary-add! dict 'DarkBlue "00008B")
+ (dictionary-add! dict 'MediumBlue "0000CD")
+ (dictionary-add! dict 'Blue "0000FF")
+ (dictionary-add! dict 'DarkGreen "006400")
+ (dictionary-add! dict 'Green "008000")
+ (dictionary-add! dict 'Teal "008080")
+ (dictionary-add! dict 'DarkCyan "008B8B")
+ (dictionary-add! dict 'DeepSkyBlue "00BFFF")
+ (dictionary-add! dict 'DarkTurquoise "00CED1")
+ (dictionary-add! dict 'MediumSpringGreen "00FA9A")
+ (dictionary-add! dict 'Lime "00FF00")
+ (dictionary-add! dict 'SpringGreen "00FF7F")
+ (dictionary-add! dict 'Aqua "00FFFF")
+ (dictionary-add! dict 'Cyan "00FFFF")
+ (dictionary-add! dict 'MidnightBlue "191970")
+ (dictionary-add! dict 'DodgerBlue "1E90FF")
+ (dictionary-add! dict 'LightSeaGreen "20B2AA")
+ (dictionary-add! dict 'ForestGreen "228B22")
+ (dictionary-add! dict 'SeaGreen "2E8B57")
+ (dictionary-add! dict 'DarkSlateGray "2F4F4F")
+ (dictionary-add! dict 'DarkSlateGrey "2F4F4F")
+ (dictionary-add! dict 'LimeGreen "32CD32")
+ (dictionary-add! dict 'MediumSeaGreen "3CB371")
+ (dictionary-add! dict 'Turquoise "40E0D0")
+ (dictionary-add! dict 'RoyalBlue "4169E1")
+ (dictionary-add! dict 'SteelBlue "4682B4")
+ (dictionary-add! dict 'DarkSlateBlue "483D8B")
+ (dictionary-add! dict 'MediumTurquoise "48D1CC")
+ (dictionary-add! dict 'Indigo "4B0082")
+ (dictionary-add! dict 'DarkOliveGreen "556B2F")
+ (dictionary-add! dict 'CadetBlue "5F9EA0")
+ (dictionary-add! dict 'CornflowerBlue "6495ED")
+ (dictionary-add! dict 'MediumAquaMarine "66CDAA")
+ (dictionary-add! dict 'DimGray "696969")
+ (dictionary-add! dict 'DimGrey "696969")
+ (dictionary-add! dict 'SlateBlue "6A5ACD")
+ (dictionary-add! dict 'OliveDrab "6B8E23")
+ (dictionary-add! dict 'SlateGray "708090")
+ (dictionary-add! dict 'SlateGrey "708090")
+ (dictionary-add! dict 'LightSlateGray "778899")
+ (dictionary-add! dict 'LightSlateGrey "778899")
+ (dictionary-add! dict 'MediumSlateBlue "7B68EE")
+ (dictionary-add! dict 'LawnGreen "7CFC00")
+ (dictionary-add! dict 'Chartreuse "7FFF00")
+ (dictionary-add! dict 'Aquamarine "7FFFD4")
+ (dictionary-add! dict 'Maroon "800000")
+ (dictionary-add! dict 'Purple "800080")
+ (dictionary-add! dict 'Olive "808000")
+ (dictionary-add! dict 'Gray "808080")
+ (dictionary-add! dict 'Grey "808080")
+ (dictionary-add! dict 'SkyBlue "87CEEB")
+ (dictionary-add! dict 'LightSkyBlue "87CEFA")
+ (dictionary-add! dict 'BlueViolet "8A2BE2")
+ (dictionary-add! dict 'DarkRed "8B0000")
+ (dictionary-add! dict 'DarkMagenta "8B008B")
+ (dictionary-add! dict 'SaddleBrown "8B4513")
+ (dictionary-add! dict 'DarkSeaGreen "8FBC8F")
+ (dictionary-add! dict 'LightGreen "90EE90")
+ (dictionary-add! dict 'MediumPurple "9370D8")
+ (dictionary-add! dict 'DarkViolet "9400D3")
+ (dictionary-add! dict 'PaleGreen "98FB98")
+ (dictionary-add! dict 'DarkOrchid "9932CC")
+ (dictionary-add! dict 'YellowGreen "9ACD32")
+ (dictionary-add! dict 'Sienna "A0522D")
+ (dictionary-add! dict 'Brown "A52A2A")
+ (dictionary-add! dict 'DarkGray "A9A9A9")
+ (dictionary-add! dict 'DarkGrey "A9A9A9")
+ (dictionary-add! dict 'LightBlue "ADD8E6")
+ (dictionary-add! dict 'GreenYellow "ADFF2F")
+ (dictionary-add! dict 'PaleTurquoise "AFEEEE")
+ (dictionary-add! dict 'LightSteelBlue "B0C4DE")
+ (dictionary-add! dict 'PowderBlue "B0E0E6")
+ (dictionary-add! dict 'FireBrick "B22222")
+ (dictionary-add! dict 'DarkGoldenRod "B8860B")
+ (dictionary-add! dict 'MediumOrchid "BA55D3")
+ (dictionary-add! dict 'RosyBrown "BC8F8F")
+ (dictionary-add! dict 'DarkKhaki "BDB76B")
+ (dictionary-add! dict 'Silver "C0C0C0")
+ (dictionary-add! dict 'MediumVioletRed "C71585")
+ (dictionary-add! dict 'IndianRed "CD5C5C")
+ (dictionary-add! dict 'Peru "CD853F")
+ (dictionary-add! dict 'Chocolate "D2691E")
+ (dictionary-add! dict 'Tan "D2B48C")
+ (dictionary-add! dict 'LightGray "D3D3D3")
+ (dictionary-add! dict 'LightGrey "D3D3D3")
+ (dictionary-add! dict 'PaleVioletRed "D87093")
+ (dictionary-add! dict 'Thistle "D8BFD8")
+ (dictionary-add! dict 'Orchid "DA70D6")
+ (dictionary-add! dict 'GoldenRod "DAA520")
+ (dictionary-add! dict 'Crimson "DC143C")
+ (dictionary-add! dict 'Gainsboro "DCDCDC")
+ (dictionary-add! dict 'Plum "DDA0DD")
+ (dictionary-add! dict 'BurlyWood "DEB887")
+ (dictionary-add! dict 'LightCyan "E0FFFF")
+ (dictionary-add! dict 'Lavender "E6E6FA")
+ (dictionary-add! dict 'DarkSalmon "E9967A")
+ (dictionary-add! dict 'Violet "EE82EE")
+ (dictionary-add! dict 'PaleGoldenRod "EEE8AA")
+ (dictionary-add! dict 'LightCoral "F08080")
+ (dictionary-add! dict 'Khaki "F0E68C")
+ (dictionary-add! dict 'AliceBlue "F0F8FF")
+ (dictionary-add! dict 'HoneyDew "F0FFF0")
+ (dictionary-add! dict 'Azure "F0FFFF")
+ (dictionary-add! dict 'SandyBrown "F4A460")
+ (dictionary-add! dict 'Wheat "F5DEB3")
+ (dictionary-add! dict 'Beige "F5F5DC")
+ (dictionary-add! dict 'WhiteSmoke "F5F5F5")
+ (dictionary-add! dict 'MintCream "F5FFFA")
+ (dictionary-add! dict 'GhostWhite "F8F8FF")
+ (dictionary-add! dict 'Salmon "FA8072")
+ (dictionary-add! dict 'AntiqueWhite "FAEBD7")
+ (dictionary-add! dict 'Linen "FAF0E6")
+ (dictionary-add! dict 'LightGoldenRodYellow "FAFAD2")
+ (dictionary-add! dict 'OldLace "FDF5E6")
+ (dictionary-add! dict 'Red "FF0000")
+ (dictionary-add! dict 'Fuchsia "FF00FF")
+ (dictionary-add! dict 'Magenta "FF00FF")
+ (dictionary-add! dict 'DeepPink "FF1493")
+ (dictionary-add! dict 'OrangeRed "FF4500")
+ (dictionary-add! dict 'Tomato "FF6347")
+ (dictionary-add! dict 'HotPink "FF69B4")
+ (dictionary-add! dict 'Coral "FF7F50")
+ (dictionary-add! dict 'Darkorange "FF8C00")
+ (dictionary-add! dict 'LightSalmon "FFA07A")
+ (dictionary-add! dict 'Orange "FFA500")
+ (dictionary-add! dict 'LightPink "FFB6C1")
+ (dictionary-add! dict 'Pink "FFC0CB")
+ (dictionary-add! dict 'Gold "FFD700")
+ (dictionary-add! dict 'PeachPuff "FFDAB9")
+ (dictionary-add! dict 'NavajoWhite "FFDEAD")
+ (dictionary-add! dict 'Moccasin "FFE4B5")
+ (dictionary-add! dict 'Bisque "FFE4C4")
+ (dictionary-add! dict 'MistyRose "FFE4E1")
+ (dictionary-add! dict 'BlanchedAlmond "FFEBCD")
+ (dictionary-add! dict 'PapayaWhip "FFEFD5")
+ (dictionary-add! dict 'LavenderBlush "FFF0F5")
+ (dictionary-add! dict 'SeaShell "FFF5EE")
+ (dictionary-add! dict 'Cornsilk "FFF8DC")
+ (dictionary-add! dict 'LemonChiffon "FFFACD")
+ (dictionary-add! dict 'FloralWhite "FFFAF0")
+ (dictionary-add! dict 'Snow "FFFAFA")
+ (dictionary-add! dict 'Yellow "FFFF00")
+ (dictionary-add! dict 'LightYellow "FFFFE0")
+ (dictionary-add! dict 'Ivory "FFFFF0")
+ (dictionary-add! dict 'White "FFFFFF")
+ ))
+
+ ))
diff --git a/scsh/scgame/scgameutil.scm b/scsh/scgame/scgameutil.scm
new file mode 100644
index 0000000..26a54f6
--- /dev/null
+++ b/scsh/scgame/scgameutil.scm
@@ -0,0 +1,50 @@
+;;; scgameutil.scm - a scheme game library 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.
+
+;; aspect-oriented features
+
+(define (aspecterror)
+ (display "Message not understood."))
+
+;; 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)))
+ ((string>=? needle hs) hs))
+ #f))
+
diff --git a/scsh/scgame/scgamewidgets.scm b/scsh/scgame/scgamewidgets.scm
new file mode 100644
index 0000000..6f56b09
--- /dev/null
+++ b/scsh/scgame/scgamewidgets.scm
@@ -0,0 +1,45 @@
+;;; scgame.scm - a scheme game library
+;;;
+;;; 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 "scgameutil.scm")
+
+(define (make-scgamewidget)
+ (lambda (msg)
+ (display "subclass responsability")))
+
+(define (make-button)
+ (let ((*widget (make-scgamewidget))
+ (*image #f)) ;; pixel array
+
+ (define (set-image filename)
+ (((make-scimage2)'load-image) filename))
+
+ (lambda (msg)
+ (cond ((eq? 'set-image) set-image)
+ (else (aspecterror)(display "make-button"))
+ ))))
diff --git a/scsh/scgame/scganadu.scm b/scsh/scgame/scganadu.scm
new file mode 100644
index 0000000..8d04127
--- /dev/null
+++ b/scsh/scgame/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.
+
+(load "scgameutil.scm")
+(load "scganaduutil.scm")
+;; This code fabricates xanadu hypertext files to attach
+;; to xanandu objects or use as metafiles
+
+(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/scgame/scganaduutil.scm b/scsh/scgame/scganaduutil.scm
new file mode 100644
index 0000000..66f378a
--- /dev/null
+++ b/scsh/scgame/scganaduutil.scm
@@ -0,0 +1,67 @@
+;;; 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.
+
+(load "scgameutil.scm")
+
+(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/scgame/test.xpm b/scsh/scgame/test.xpm
new file mode 100644
index 0000000..f6d1916
--- /dev/null
+++ b/scsh/scgame/test.xpm
@@ -0,0 +1,22 @@
+/* XPM */
+static char * test_xpm[] = {
+"16 16 3 1",
+" c gray77",
+". c #000000000000",
+"X c #861782078617",
+" ",
+" ",
+"............... ",
+". . . . . . . .X",
+"...............X",
+" X.XXXXXXX.XXXXX",
+" .X .X ",
+" .X .X ",
+" .X .X ",
+" .X .X ",
+"............... ",
+" . . . . . . . X",
+"...............X",
+" XXXXXXXXXXXXXXX",
+" ",
+" "};
diff --git a/scsh/tmail/AUTHORS b/scsh/tmail/AUTHORS
new file mode 100644
index 0000000..c2430eb
--- /dev/null
+++ b/scsh/tmail/AUTHORS
@@ -0,0 +1 @@
+Copyright (C) 2011-2012 Johan Ceuppens
diff --git a/scsh/tmail/BLURB b/scsh/tmail/BLURB
new file mode 100644
index 0000000..c40ecf5
--- /dev/null
+++ b/scsh/tmail/BLURB
@@ -0,0 +1 @@
+tmail : a client-server mail system
diff --git a/scsh/tmail/NEWS b/scsh/tmail/NEWS
new file mode 100644
index 0000000..bb09772
--- /dev/null
+++ b/scsh/tmail/NEWS
@@ -0,0 +1,12 @@
+version 0.1
+* working connection with a few commands (telnet localhost 1025 and
+* type in MAIL\r\n or QUIT\r\n
+* tdaemon.scm script which can be run in scsh to (run-daemon-child staterecord)
+* "rc" alike tforks.scm, tserver.scm tclient.scm which contain tell-client and ask-server methods.
+* tforks.scm contains record and daemon to be spawned by e.g. init or daemontools
+* and uses fork-and-forget with 10 commands per session.
+* old/ code directory
+* daemon state record (port, host, etc.)
+* telnetable daemon
+* daemon state record
+* dispatch object second executable file
diff --git a/scsh/tmail/README b/scsh/tmail/README
new file mode 100644
index 0000000..da109c1
--- /dev/null
+++ b/scsh/tmail/README
@@ -0,0 +1,10 @@
+- This is a mail daemon (lots of protocols)
+Basically run scsh, ',open records sockets reduce' or sometimes
+',open sockets records' and '(load "tdaemon.scm")'
+telnet localhost 1025 and type in APOP\r\n or QUIT\r\n
+for asking the server.
+
+mailer daemon command history:
+APOP retrieves full mailbox (FIXME)
+STAT returns
+LIST returns
diff --git a/scsh/tmail/packages.scm b/scsh/tmail/packages.scm
new file mode 100644
index 0000000..6743044
--- /dev/null
+++ b/scsh/tmail/packages.scm
@@ -0,0 +1,8 @@
+(define-interface tmail-interface
+ (export
+ run-daemon-child))
+
+(define-structure tmail
+ tmail-interface
+ (open scheme)
+ (files tdaemon trecords tclient tserver tforks tmailbox))
\ No newline at end of file
diff --git a/scsh/tmail/pkg-def.scm b/scsh/tmail/pkg-def.scm
new file mode 100644
index 0000000..fe6baad
--- /dev/null
+++ b/scsh/tmail/pkg-def.scm
@@ -0,0 +1,19 @@
+(define-package "tmail"
+ (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 "tdaemon.scm" 'scheme)
+ (install-file "tforks.scm" 'scheme)
+ (install-file "tclient.scm" 'scheme)
+ (install-file "trecords.scm" 'scheme)
+ (install-file "tmailbox.scm" 'scheme)
+ (install-file "tmailbox-load.scm" 'scheme)
+ (install-file "util.scm" 'scheme)
+ (install-file "tserver.scm" 'scheme))
diff --git a/scsh/tmail/tclient.scm b/scsh/tmail/tclient.scm
new file mode 100644
index 0000000..e33d02e
--- /dev/null
+++ b/scsh/tmail/tclient.scm
@@ -0,0 +1,38 @@
+;;; tclient.scm - a full-duplex connect-to-server
+;;;
+;;; 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 (ask-server request port-number)
+ (call-with-values
+ (lambda ()
+ (socket-client (get-host-name) port-number))
+ (lambda (in out)
+ (display request out)
+ (close-output-port out)
+ (let ((answer (make-string-input-port in))) ; returns any server response into some string
+ (close-input-port in)
+ answer))))
diff --git a/scsh/tmail/tdaemon.scm b/scsh/tmail/tdaemon.scm
new file mode 100644
index 0000000..285b928
--- /dev/null
+++ b/scsh/tmail/tdaemon.scm
@@ -0,0 +1,59 @@
+;;; tdaemon.scm - a scheme pop mail daemon (instantiated)
+;;;
+;;; 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.
+
+;;#!/home/erana/scheme/bin/scsh -ds \
+;;!#
+
+;;#!/home/erana/scheme/bin/scsh \
+;;-lm tmail.scm -o mail-daemon -s
+
+(load "trecords.scm")
+(load "tclient.scm")
+(load "tserver.scm")
+(load "tforks.scm")
+(display "FIXMES: mail-daemon structure needs carriage return statement")
+(newline)
+
+(define rc (make-daemon-record
+ (delay "localhost") ;; virtual host
+ (delay 1110)
+ (delay (open-socket (force (port rc))))
+ (delay "POP3 tmail server ready")
+ (delay "+OK ")
+ (delay "APOP ")
+ (delay "STAT")
+ (delay "LIST")
+ (delay "+OK POP3 server signing off")
+ (delay "Exceeded maximum transactions.")
+ (delay "500 Command not understood.")
+ (delay "HELO")
+ (delay "EHLO")))
+(run-daemon-child rc)
+
+(display "mail-daemon ends.")
+(newline)
diff --git a/scsh/tmail/tforks.scm b/scsh/tmail/tforks.scm
new file mode 100644
index 0000000..e54ee83
--- /dev/null
+++ b/scsh/tmail/tforks.scm
@@ -0,0 +1,118 @@
+;;; tforks.scm - a scheme daemon child process
+;;;
+;;; 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 "trecords.scm")
+(load "tserver.scm")
+(load "tmailbox-load.scm")
+
+;; You can spawn this
+
+(define (run-daemon-child rec)
+ (display "Opening listening socket on host : ")
+ (display (force (hostname rec)))
+ (display " port unknown at this stage, default 1110 ")
+ (display " ...")
+ (newline)
+ (fork-and-forget
+ (let ((socket (force (sock rec))))
+ (begin
+ (
+ (lambda (request portnumber)
+ (call-with-values
+ (lambda ()
+ (socket-accept socket))
+ (lambda (in out)
+ (write request out)
+ (do ((i 0 (+ i 1)))
+ ((> i 9)(display "Quitting mail daemon child.")(newline))
+ ;; (iterate loop
+ ;; ((count* i 0))
+ ;; ()
+ ;; (if (>= i 10)
+ ;; (display "Quitting mail daemon child.")(newline)
+
+
+ (call-with-values ;; FIXME (let ((answer2 (read in)))
+ (lambda ()
+ (list (read in)(read in)))
+ (lambda (answer)
+ (let ((answer2 (car answer))
+ (answer3 (if (not (null? (cdr answer)))
+ (cadr answer)
+ 'foo)))
+ (display "Asked something : ")(display (symbol->string answer2))(display " ")(display answer3)(newline)
+ (if (symbol? answer2)
+ (cond ((eq? 'APOP answer2)
+ (write mailbox-contents out)
+ ;; FIXME write "" to user's mailbox file
+ ;;(let ((out2 (open-output-file (string-append spooldirectory (getenv "USER")))))
+ ;; (write out2 ""))
+ )
+ ((eq? 'STAT answer2)
+ #t)
+ ((eq? 'LIST answer2)
+ #t)
+ ((eq? 'RETR answer2)
+ (let ((idx (string->number (symbol->string answer3))))
+ (if idx
+ (write (tmail-get-mail-with-index (getenv "USER") idx) out))))
+ ;; for brokeness
+ ((eq? 'USER answer2)
+ ;;FIXME overflow
+ (let ((username (if (number? answer3)
+ (number->string answer3)
+ (symbol->string answer3))))
+ (setenv "USER" username)
+ (write "+OK user accepted - not implemented" out)))
+ ((eq? 'PASS answer2)
+ (let ((pass (if (number? answer3)
+ (number->string answer3)
+ (symbol->string answer3))))
+ (write "+OK password accepted - not implemented" out)))
+ ((eq? 'QUIT answer2)
+ (write (force (BYE rec)) out)
+ (close-input-port in)
+ (close-socket socket)
+ (close-output-port out)
+ (exit))
+ (else
+ (write (force (ERROR500 rec)) out))
+ ))
+ ))))
+ (write (force (SPAWNEND rec)) out)
+ (write (force (BYE rec)) out)
+
+ (close-input-port in)
+ (close-socket socket)
+ (close-output-port out)
+
+ (exit)
+
+ )))
+ (force (MOTD rec)) (port rec))
+ ))))
\ No newline at end of file
diff --git a/scsh/tmail/tmailbox-load.scm b/scsh/tmail/tmailbox-load.scm
new file mode 100644
index 0000000..9bd9a05
--- /dev/null
+++ b/scsh/tmail/tmailbox-load.scm
@@ -0,0 +1,53 @@
+;;; tmailbox.scm - a scheme mailbox system for smtp
+;;;
+;;; 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 "tmailbox.scm")
+
+;; read in current user's mailbox
+
+(define mailbox-contents (tmail-mailbox-contents (getenv "USER")))
+
+;; get mail with index
+
+(define (tmail-get-mail-with-index usernamestr idx)
+ (let ((mailboxcontents tmail-mailbox-contents))
+ (let ((s "")
+ (i 0))
+ ;; FIXME make do*
+ (do ((j 0 (+ j 1)))
+ ((string=? "From " s)
+ (set! i (+ i 1))
+ (if (= i (+ idx 1))
+ s)
+ )
+ (let ((c (string-ref mailboxcontents j)))
+ (if (string=? "From " s)
+ (set! s "From "))
+ (string-append s (string c)))))))
+
+
diff --git a/scsh/tmail/tmailbox.scm b/scsh/tmail/tmailbox.scm
new file mode 100644
index 0000000..5d427fd
--- /dev/null
+++ b/scsh/tmail/tmailbox.scm
@@ -0,0 +1,46 @@
+;;; tmailbox.scm - a scheme mailbox system for smtp
+;;;
+;;; 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 spooldirectory "/var/spool/mail/")
+
+(define (tmail-read-in-mailbox username)
+ (let ((file (string-append spooldirectory username)))
+ (display file)
+ (let ((in (open-input-file file)))
+ (let ((mailboxcontents ""))
+ (do ((s (read-char in)(read-char in))
+ (i 0 (+ i 1)))
+ ((eof-object? s) (if (= (string-length mailboxcontents) 0)
+ (display "empty mailbox"))
+ mailboxcontents)
+ (set! mailboxcontents (string-append mailboxcontents (string s)))
+ )))))
+
+;; global
+(define (tmail-mailbox-contents username) (tmail-read-in-mailbox username))
+
diff --git a/scsh/tmail/trecords.scm b/scsh/tmail/trecords.scm
new file mode 100644
index 0000000..6782ac5
--- /dev/null
+++ b/scsh/tmail/trecords.scm
@@ -0,0 +1,57 @@
+;;; trecords.scm - records for tmail
+;;;
+;;; 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 :daemon-record
+ (make-record-type 'daemon-record
+ '(hostname port sock MOTD ACK APOP STAT LIST BYE SPAWNEND ERROR500 HELO EHLO)))
+(define make-daemon-record
+ (record-constructor :daemon-record
+ '(hostname port sock MOTD ACK APOP STAT LIST BYE SPAWNEND ERROR500 HELO EHLO)))
+;; (define make-daemon-record-default
+;; (record-constructor :daemon-record
+;; '(hostname
+;; 1025 #f
+;; "Hello."
+;; "OK."
+;; "Bye."
+;; "500 Command not understood."
+;; "EHLO Server ready.")))
+(define hostname (record-accessor :daemon-record 'hostname))
+(define port (record-accessor :daemon-record 'port))
+(define sock (record-accessor :daemon-record 'sock))
+(define MOTD (record-accessor :daemon-record 'MOTD))
+(define ACK (record-accessor :daemon-record 'ACK))
+(define APOP (record-accessor :daemon-record 'APOP))
+(define STAT (record-accessor :daemon-record 'STAT))
+(define LIST (record-accessor :daemon-record 'LIST))
+(define BYE (record-accessor :daemon-record 'BYE))
+(define SPAWNEND (record-accessor :daemon-record 'SPAWNEND))
+(define ERROR500 (record-accessor :daemon-record 'ERROR500))
+(define HELO (record-accessor :daemon-record 'HELO))
+(define EHLO (record-accessor :daemon-record 'EHLO))
+
diff --git a/scsh/tmail/tserver.scm b/scsh/tmail/tserver.scm
new file mode 100644
index 0000000..0924255
--- /dev/null
+++ b/scsh/tmail/tserver.scm
@@ -0,0 +1,43 @@
+;;; tserver.scm - a full-duplex connect-to-client
+;;;
+;;; 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 (tell-client request port-number sock)
+ (call-with-values
+ (lambda ()
+ (socket-accept sock))
+ (lambda (in out)
+ (display request out)
+ (display #\newline out)
+ ;;(display #\return out)
+ ;;FIXME(close-output-port out)
+ ;;(let ((answer (make-string-input-port in))) ; returns any server response into some string
+ ;;FIXME(close-input-port in)
+ ;;answer)
+ )))
+
+
diff --git a/scsh/tmail/util.scm b/scsh/tmail/util.scm
new file mode 100644
index 0000000..f6a5e40
--- /dev/null
+++ b/scsh/tmail/util.scm
@@ -0,0 +1,31 @@
+;;; util.scm - tmail utilities
+;;;
+;;; 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 " message not understood. "))
+
+