sunterlib/scsh/scgame/scgame.scm

;;; scgame.scm - a scheme game library (needs a scx-0.2 or scheme48-fb)
;;;
;;; 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")

;; NOTE: You need to load a display and window e.g.
;; (define dpy (open-display))
;; (define root (default-root-window dpy))
;; (define width 640) (define height 480)
;; (define win (create-simple-window dpy root 0 0 width height 1 black white))

;; 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

;; debugging vars

(load "config.scm")
(define (display-msg . msg)
  (if SCGAMEDEBUG
      (for-each display (append (list (aspectmsg) " ") msg))
      (newline)))

;; override for scx-0.2
(define (putpixel x y colorname)
 (let ((gc (create-gc dpy win
                      (make-gc-value-alist (background (string->color 'White)
                                                       (foreground (string->Color colorname)))))))
   (draw-point dpy win gc (inexact->exact x) (inexact->exact y))))

(define (putpixel x y foregroundcolorname backgroundcolorname)
  (let ((gc (create-gc dpy win
                       (make-gc-value-alist (background (string->color backgroundcolorname)
                                                        (foreground (string->Color foregroundcolorname)))))))
    (draw-point dpy win gc (inexact->exact x) (inexact->exact y))))


(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-msg "drawing line...")
      ;;This should be optimized 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-msg "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 'Black)
				    (putpixel x y ))

				(set! error (- error deltay))
				(if (< error 0)
				    (set! y (+ y ystep))
				    (set! error (+ error deltax)))
				(range x0 x1))
		      ))))))))

    (define (draw-lines l1 . w)
      (display-msg "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-xpm-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-native filename)
      (xputxpm filename))

    (define (load-xpm-image-scx win filename)
      (read-file-to-pixmap win filename #()));;FIXME xpm-attributes == '()

    (define (load-xpm-image filename)
      (let ((in (open-input-file filename))
	    (colorcharsdictionary (make-color-dictionary 8)) ;;
	    (colorcharstable (make-xpm-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 win filename)
      ;; FIXME read in xpm or png
      (display-msg "loading image..")
      (cond ((string<=? ".xpm" filename)
             (display-msg "loading xpm suffixed file..")
	     (load-xpm-image-scx win filename)
	     )
            (else (display-msg "no supported image format found"))))

    (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"))))
	   ))))