Unnamed Fossil Project

;
;       PRIMITIVES
;               Contains some primitives such as POINT, SIZE, RECT and
;               methods for working with they
;       CREATOR         vasavit, 03.11.2011
(require-extension defstruct)

;       POINT
;               One point on a screen.  POINT consists of two values:
;               X (number) and Y (number).
(defstruct point x y)
(define empty-point
        (make-point x: -1 y: -1))
(define (point-x-set! p x)
        (make-point x: x y: (point-y p)))
(define (point-y-set! p y)
        (make-point y: y x: (point-x p)))
(define (point->alist p)
        (list (cons 'x (point-x p)) (cons 'y (point-y p))))
(define (alist->point l)
        (make-point x: (cdr (assq 'x l)) y: (cdr (assq 'y l))))

;       SIZE
;               Represents size of rectangle on a screen.  SIZE consists of two
;               values - WIDTH (number) and HEIGHT (number).
(defstruct size width height)
(define empty-size
        (make-size width: 0 height: 0))
(define (size-width-set! s w)
        (make-size width: w  height: (size-height s)))
(define (size-height-set! s h)
        (make-size height: h width: (size-width s)))
(define (size->alist s)
        (list (cons 'width (size-width s)) (cons 'height (size-height s))))
(define (alist->size l)
        (make-size width: (cdr (assq 'width l)) height: (cdr (assq 'height l))))

;       RECT
;               Represents rectangle on a screen.  RECT consists of two values:
;               ORIGIN (origin, POINT) and SIZE (size, SIZE).
(defstruct rect origin size)
(define empty-rect
        (make-rect origin: empty-point size: empty-size))
(define (rect-origin-set! r o)
        (make-rect origin: o size: (rect-size r)))
(define (rect-size-set! r s)
        (make-rect size: s origin: (rect-origin r)))
(define (rect->alist r)
        (list
                (cons 'origin (point->alist (rect-origin r)))
                (cons 'size   (size->alist  (rect-size   r)))))
(define (alist->rect l)
        (make-rect
                origin: (alist->point (cdr (assq 'origin l)))
                size:   (alist->size  (cdr (assq 'size   l))))) 

;
;       PRIMITIVES-TESTS
;               Test for PRIMITIVES module.
;       CREATOR         vasalvit, 03.11.2011
(require-extension srfi-78)
(load "primitives.scm")

; POINT tests
(let* (
        (a (make-point x: 30 y: 20))
        (b (make-point x: 30 y: 40))
        (c (make-point x: 10 y: 40))
        (l '((x . 30) (y . 40)))
        (== equal?)
        (!= (lambda (p1 p2) (not (== p1 p2)))))
                (display "POINT")
                (check-set-mode! 'report-failed)
                (check-reset!)
                (check b (=> !=) a)
                (check b (=> ==) b)
                (check b (=> ==) (make-point x: (point-x a) y: (point-y c)))
                (check c (=> ==) (point-x-set! b (point-x c)))
                (check a (=> ==) (point-y-set! b (point-y a)))
                (check l => (point->alist b))
                (check b => (alist->point l))
                (check-report)
)

; SIZE tests
(let* (
        (a (make-size width: 300 height: 200))
        (b (make-size width: 300 height: 400))
        (c (make-size width: 100 height: 400))
        (l '((width . 300) (height . 400)))
        (== equal?)
        (!= (lambda (s1 s2) (not (== s1 s2)))))
                (display "SIZE")
                (check-set-mode! 'report-failed)
                (check-reset!)
                (check b (=> !=) a)
                (check b (=> ==) b)
                (check b (=> ==) (make-size width: (size-width a) height: (size-height c)))
                (check c (=> ==) (size-width-set!  b (size-width  c)))
                (check a (=> ==) (size-height-set! b (size-height a)))
                (check l => (size->alist b))
                (check b => (alist->size l))
                (check-report)
)

; RECT tests
(let* (
        (pa (make-point x: 30 y: 20))
        (pb (make-point y: 30 y: 40))
        (sa (make-size width: 300 height: 200))
        (sb (make-size width: 300 height: 400))
        (a (make-rect origin: pa size: sa))
        (b (make-rect origin: pa size: sb))
        (c (make-rect origin: pb size: sb))
        (l '((origin . ((x . 30) (y . 20))) (size . ((width . 300) (height . 400)))))
        (== equal?)
        (!= (lambda (r1 r2) (not (== r1 r2)))))
                (display "RECT")
                (check-set-mode! 'report-failed)
                (check-reset!)
                (check b (=> !=) a)
                (check b (=> ==) b)
                (check b (=> ==) (make-rect origin: (rect-origin a) size: (rect-size c)))
                (check c (=> ==) (rect-origin-set! b (rect-origin c)))
                (check a (=> ==) (rect-size-set!   b (rect-size   a)))
                (check l => (rect->alist b))
                (check b => (alist->rect l))
                (check-report)
)