;;; $Id: window-layout-mod.scm,v 1.1 2006/01/17 18:14:52 leavens Exp $
;;;
;;; <window-layout> ::=
;;;    (window <symbol> <number> <number>) "window (name width height)"
;;;  | (horizontal {<window-layout>}*)     "horizontal (subwindows)"
;;;  | (vertical {<window-layout>}*)       "vertical (subwindows)"

(module window-layout-mod (lib "typedscm.ss" "typedscm")

(provide window-layout? window? horizontal? vertical?
         window horizontal vertical 
         window->name window->width
         window->height horizontal->subwindows vertical->subwindows
         parse-window-layout)

;; type predicate
(deftype window-layout? (type-predicate-for window-layout))

;; case testers (discriminators)
(deftype window? (-> (window-layout) boolean))
(deftype horizontal? (-> (window-layout) boolean))
(deftype vertical? (-> (window-layout) boolean))

;; constructors
(deftype window (-> (symbol number number) window-layout))
(deftype horizontal (-> ((list-of window-layout)) window-layout))
(deftype vertical (-> ((list-of window-layout)) window-layout))

;; observers 
(deftype window->name (-> (window-layout) symbol))
(deftype window->width (-> (window-layout) number))
(deftype window->height (-> (window-layout) number))
(deftype horizontal->subwindows (-> (window-layout) (list-of window-layout)))
(deftype vertical->subwindows (-> (window-layout) (list-of window-layout)))

;; parsing/bless input correctness
(deftype parse-window-layout (-> (datum) window-layout))

(require (lib "all-mod.scm" "lib342"))

(defrep (window-layout (list-of datum)))

(define window-layout?
  (lambda (d)
    (has-type-trusted
      boolean
      (or (window? d)
          (and (horizontal? d) (all window-layout? (cdr d)))
          (and (vertical? d) (all window-layout? (cdr d)))))))

(define window?
  (lambda (wl)
    (and (list? wl) (= (length wl) 4)
         (eq? (car wl) 'window)
         (symbol? (cadr wl)) (number? (caddr wl)) (number? (cadddr wl)))))

(define horizontal?
  (lambda (wl)
    (and (list? wl) (>= (length wl) 1)
         (eq? (car wl) 'horizontal))))

(define vertical?
  (lambda (wl)
    (and (list? wl) (>= (length wl) 1)
         (eq? (car wl) 'vertical))))

(define window
  (lambda (name width height)
    (list 'window name width height)))

(define horizontal
  (lambda (lwl)
    (cons 'horizontal lwl)))

(define vertical
  (lambda (lwl)
    (cons 'vertical lwl)))

(deftype extract-maker (-> ((-> (window-layout) boolean) string)
                           (-> (window-layout) (list-of datum))))
(define extract-maker
  (lambda (test? name)
    (lambda (x)
      (if (test? x)
          x
          (error (string-append "not a " name " window-layout:") x)))))

(define window->name
  (lambda (wl)
    (test-type symbol? (cadr ((extract-maker window? "window") wl)))))

(define window->width
  (lambda (wl)
    (test-type number? (caddr ((extract-maker window? "window") wl)))))

(define window->height
  (lambda (wl)
    (test-type number? (cadddr ((extract-maker window? "window") wl)))))

(define horizontal->subwindows
  (lambda (wl)
    (test-type (list-of (list-of datum?))
               (cdr ((extract-maker horizontal? "horizontal") wl)))))

(define vertical->subwindows
  (lambda (wl)
    (test-type (list-of (list-of datum?))
               (cdr ((extract-maker vertical? "vertical") wl)))))

(define parse-window-layout
  (lambda (d)
    (test-type
      (list-of datum?)
      (cond
       ((window? d) (window (cadr d) (caddr d) (cadddr d)))
       ((horizontal? d) (horizontal (map parse-window-layout (cdr d))))
       ((vertical? d) (vertical (map parse-window-layout (cdr d))))
       (else (error "parse-window-layout: bad syntax:" d))))))

) ; end module