#lang racket
;*----------------------------------*
;* >>> Canvas <<< *
;* >>> Jaarproject 2011-2012 <<< *
;* *
;* SOFT Software Languages Lab *
;* 2011 *
;*----------------------------------*
; load graphical library
(require graphics/graphics
racket/draw
racket/math);added by sam
; initialize the library
(open-graphics)
(provide fill-rectangle!
fill-ellipse!
draw-line!
on-key!
draw-text!
put-pixel!
start-game-loop
current-time
make-color)
;---------------------------------------------------------------------
; Canvas
;---------------------------------------------------------------------
(define ScaleWindowFactor 1)
(define Pixels-x 1366) ;Original resolution: 800*600
(define Pixels-y 768) ;When changing the resolution, please also change it at the very beginning of vectors.rkt
(define red #xf00)
(define green #x0f0)
(define blue #x00f)
(define (make-color r g b)
(+ (* r 16 16) (* g 16) b))
(define (Windowscale x)
(* x ScaleWindowFactor))
(define MainWindow
(open-viewport "Jaarproject (2011-2012)" (Windowscale Pixels-x) (Windowscale Pixels-y)))
(define (my-make-posn x y)
(make-posn (Windowscale x) (Windowscale y)))
(define (12bitColor2rgb color)
(make-rgb (/ (bitwise-and color #xf00) #xf00)
(/ (bitwise-and color #x0f0) #x0f0)
(/ (bitwise-and color #x00f) #x00f)))
(define (fill-rectangle! x y width height color)
(define posn (my-make-posn x (- Pixels-y y height)))
((draw-solid-rectangle MainWindow)
posn
(Windowscale width)
(Windowscale height)
(12bitColor2rgb color)))
(define (draw-text! x y str color)
(define posn (my-make-posn x (- Pixels-y y)))
((draw-string MainWindow) posn str (12bitColor2rgb color)))
(define (put-pixel! x y color)
(define posn (my-make-posn x (- Pixels-y y)))
((draw-pixel MainWindow) posn (12bitColor2rgb color)))
(define (fill-ellipse! x y width height color)
(define posn (my-make-posn (- x (/ width 2) ) (- Pixels-y (/ height 2) y)))
((draw-solid-ellipse MainWindow) posn (Windowscale width) (Windowscale height) (12bitColor2rgb color)))
(define (draw-line! x1 y1 x2 y2 color)
(define posn1 (my-make-posn x1 (- Pixels-y y1)))
(define posn2 (my-make-posn x2 (- Pixels-y y2)))
((draw-line MainWindow) posn1 posn2 (12bitColor2rgb color)))
;#####--------------------##########--------------------#####
;#####-------------------Added by Sam-------------------#####
;#####--------------------##########--------------------#####
;Todo: add support for colours as represented in the rest of the code
;I probably have to convert integers to strings.
;Original positions which don't even make sense
;|------------|
;|(0,0) (x,0)|
;| |
;| |
;|(0,y) (x,y)|
;|------------|
;
;What it should actually be like with the origin where it makes much more sense
;-Relative to the 'wrong' origin
;-h = window height
;|---------------|
;|(0,h-y) (x,h-y)|
;| |
;| |
;|(0,0) (x,0)|
;|---------------|
(define (degrees->radians deg)
(* deg (/ pi 180)))
(define makeVec cons)
(define getX car)
(define getY cdr)
;orig is the origin of the vector
;rotate-orig is the origin around which the rotation should happen
;alpha should be converted to radians first, because degrees are so much better but radians are expected
;returns the new position of the vector after rotation
(define (rotateVec alpha orig rotate-orig)
(let ((old-x (getX orig))
(old-y (getY orig))
(rotate-x (getX rotate-orig))
(rotate-y (getY rotate-orig))
(radians (degrees->radians alpha)))
(makeVec (+ (- (* (- old-x rotate-x) (cos radians))
(* (- old-y rotate-y) (sin radians)))
rotate-x)
(+ (+ (* (- old-x rotate-x) (sin radians))
(* (- old-y rotate-y) (cos radians)))
rotate-y))))
(define (make-rectangle x y width height angle rotate-x rotate-y colour)
(let* ((pos1 (makeVec x y))
(pos2 (makeVec (+ x width) y))
(pos3 (makeVec x (+ y height)))
(pos4 (makeVec (+ x width) (+ y height)))
(rotateOrig (makeVec rotate-x rotate-y))
(pos1-rotated (rotateVec angle pos1 rotateOrig))
(pos2-rotated (rotateVec angle pos2 rotateOrig))
(pos3-rotated (rotateVec angle pos3 rotateOrig))
(pos4-rotated (rotateVec angle pos4 rotateOrig)))
(draw-line! (getX pos1) (getY pos1) (getX pos2) (getY pos2) colour)
(draw-line! (getX pos1) (getY pos1) (getX pos3) (getY pos3) colour)
(draw-line! (getX pos2) (getY pos2) (getX pos4) (getY pos4) colour)
(draw-line! (getX pos3) (getY pos3) (getX pos4) (getY pos4) colour)
(draw-line! (getX pos1-rotated) (getY pos1-rotated) (getX pos2-rotated) (getY pos2-rotated) colour)
(draw-line! (getX pos1-rotated) (getY pos1-rotated) (getX pos3-rotated) (getY pos3-rotated) colour)
(draw-line! (getX pos2-rotated) (getY pos2-rotated) (getX pos4-rotated) (getY pos4-rotated) colour)
(draw-line! (getX pos3-rotated) (getY pos3-rotated) (getX pos4-rotated) (getY pos4-rotated) colour)
((draw-solid-polygon MainWindow)
(list (my-make-posn (getX pos3-rotated)
(getY pos3-rotated))
(my-make-posn (getX pos4-rotated)
(getY pos4-rotated))
(my-make-posn (getX pos2-rotated)
(getY pos2-rotated))
(my-make-posn (getX pos1-rotated)
(getY pos1-rotated)))
(my-make-posn 0 495)
(12bitColor2rgb (make-color 15 0 0)))))
(define rectangle (make-rectangle 100 100 25 100 -45 112.5 100 (make-color 0 0 0)))
;#####--------------------##########--------------------#####
;#####--------------------------------------------------#####
;#####--------------------##########--------------------#####
(define commands '())
(define (make-command l1 l2)
(cons l1 l2))
(define (on-key! name function)
(set! commands (cons (cons name function) commands)))
(define (execute command select)
(let ((pair (assoc command commands)))
(when pair
((cdr pair)))))
(define (action a) a)
(define (do-action a) (a))
((set-on-key-event MainWindow)
(lambda (keypress y)
(cond ((not keypress) null)
((eq? (key-value keypress) 'release) 'dont-care)
(else
(execute (key-value keypress) action)))))
;---------------------------------------------------------------------
; Timer
;---------------------------------------------------------------------
(define CPU_FREQ 60000000)
(define (make-timer)
(define time 0)
(define wait-time (/ 1 CPU_FREQ))
(define timer-thread
(thread (lambda ()
(let loop ()
(sleep 0.005) ;wait-time)
(set! time (+ 1 time))
(loop)))))
(define (dispatch msg)
(cond ((eq? msg 'time) time)
((eq? msg 'start)
(thread-resume timer-thread))
((eq? msg 'restart)
(set! time 0)
(thread-resume timer-thread))
((eq? msg 'reset)
(thread-suspend timer-thread)
(set! time 0))
((eq? msg 'stop) (thread-suspend timer-thread))
((eq? msg 'set-period!)
(lambda (period)
(set! wait-time (* (+ period 1) (/ 1 CPU_FREQ)))))
))
(thread-suspend timer-thread)
(set! time 0)
dispatch)
(define timer0 (make-timer))
((timer0 'set-period!) 100000)
(define (stop-timer timer) (timer 'stop))
(define (start-timer timer) (timer 'start))
(define (restart-timer timer) (timer 'restart))
(define (reset-timer timer) (timer 'reset))
(define (read-timer timer) (timer 'time))
(define (write-timer-period timer period) ((timer 'set-period!) period))
(start-timer timer0)
(define (current-time)
(timer0 'time))
(define (start-game-loop loop)
((set-on-tick-event MainWindow) 1 (lambda x (loop))))