Joren/Pacman-Project
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

first commit

Browse Source
This commit is contained in:
joren
2026-03-23 10:28:54 +01:00
commit 3abc9aae55
109 changed files with 2467 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

BIN
pp1/PacMan.bmp Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 113 KiB

BIN
pp1/PacMan.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 8.5 KiB

BIN
pp1/PacMan_mask.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 673 B

72
pp1/main.rkt Normal file
View File

@@ -0,0 +1,72 @@
(import (scheme base)
(scheme write)
(pp1 graphics))
;; 1. Configuration
#lang r7rs
(define tile-size 40)
(define wall-color "blue")
(define pellet-color "white")
(define pellet-size 10) ; Size of the dot
;; 2. Map Data (1 = Wall, 0 = Pellet)
(define map-data
'((1 1 1 1 1 1 1 1 1 1)
(1 0 0 0 0 0 0 0 0 1)
(1 0 1 1 0 0 1 1 0 1)
(1 0 1 1 0 0 1 1 0 1)
(1 0 0 0 0 0 0 0 0 1)
(1 0 1 1 1 1 1 1 0 1)
(1 0 0 0 0 0 0 0 0 1)
(1 1 1 1 1 1 1 1 1 1)))
;; 3. Setup Window
(define screen-width (* 10 tile-size))
(define screen-height (* 8 tile-size))
(define screen (make-window screen-width screen-height "PacMan"))
((screen 'set-background!) "black")
(define game-layer ((screen 'new-layer!)))
;; 4. Build Level Function
(define (build-level layer grid)
(let loop-y ((rows grid) (y 0))
(unless (null? rows)
(let loop-x ((cols (car rows)) (x 0))
(unless (null? cols)
(let ((val (car cols))
(tile (make-tile tile-size tile-size)[cite_start])) ; Create a fresh transparent tile [cite: 81]
(cond
;; CASE 1: WALL
((= val 1)
((tile 'draw-rectangle!) [cite_start]0 0 tile-size tile-size wall-color) [cite: 85]
((tile 'set-x!) (* x tile-size))
((tile 'set-y!) (* y tile-size))
((layer 'add-drawable!) [cite_start]tile)) [cite: 158]
;; CASE 2: PELLET (DOT)
((= val 0)
;; Calculate offset to center the dot
(let ((offset (/ (- tile-size pellet-size) 2)))
((tile 'draw-ellipse!) [cite_start]offset offset pellet-size pellet-size pellet-color) [cite: 86]
((tile 'set-x!) (* x tile-size))
((tile 'set-y!) (* y tile-size))
((layer 'add-drawable!) tile))))
(loop-x (cdr cols) (+ x 1))))
(loop-y (cdr rows) (+ y 1)))))
;; 5. Run it
(build-level game-layer map-data)
;; 6. Add Pacman (on top)
(generate-mask "/home/joren/Downloads/pp1/PacMan.bmp" "black") ; Ensure background color matches your image
(define pacman (make-bitmap-tile
"/home/joren/Downloads/pp1/PacMan.bmp"
"/home/joren/Downloads/pp1/PacMan_mask.png"))
;; Place Pacman at (1, 1)
((pacman 'set-x!) (* 1 tile-size))
((pacman 'set-y!) (* 1 tile-size))
((game-layer 'add-drawable!) pacman)

16
pp1/main.rkt~ Normal file
View File

@@ -0,0 +1,16 @@
#lang r7rs
(import (scheme base)
(scheme write)
(pp1 graphics))
;;GUI;;
;window;
(define screen-width 600)
(define screen-height 700)
(define screen (make-window screen-width screen-height "PacMan"))
((screen 'set-background!) "black")
;pacman;
(define pacman_image (get-bitmap "/Users/yousraajridi/Desktop/pacman1.png"))
(define pacman (get-bitmap-section pacman_image 50 50 20 20))

1
pp1/pp1/compiled/drracket/errortrace/graphics_rkt.dep Normal file
View File

@@ -0,0 +1 @@
("9.0" ta6le ("c3e5c0758f9b8ecce67b10bfe77b9463dfa6fbe7" . "c087ac06cfa4a70c5517dd89b10483400966c12d") (collects #"compatibility" #"mlist.rkt") (collects #"drracket" #"private" #"drracket-errortrace-key.rkt") (collects #"racket" #"gui" #"base.rkt") (collects #"racket" #"main.rkt") (collects #"racket" #"runtime-config.rkt") (collects #"racket" #"string.rkt"))

BIN
pp1/pp1/compiled/drracket/errortrace/graphics_rkt.zo Normal file
View File

Binary file not shown.

1
pp1/pp1/compiled/graphics_rkt.dep Normal file
View File

@@ -0,0 +1 @@
("9.1" ta6le ("c3e5c0758f9b8ecce67b10bfe77b9463dfa6fbe7" . "4e2cba1cdda1424dfa165dc344391a01e09bfc30") (collects #"compatibility" #"mlist.rkt") (collects #"racket" #"gui" #"base.rkt") (collects #"racket" #"main.rkt") (collects #"racket" #"runtime-config.rkt") (collects #"racket" #"string.rkt"))

BIN
pp1/pp1/compiled/graphics_rkt.zo Normal file
View File

Binary file not shown.

1
pp1/pp1/compiled/info_rkt.dep Normal file
View File

@@ -0,0 +1 @@
("9.1" ta6le ("5a9055df4313931940f2f8fde89a20f87d4a519a" . "c86336a90cbc6d6d5c5a623dc9eb18c4ccfa3e16") (collects #"info" #"main.rkt") (collects #"setup" #"infotab.rkt"))

BIN
pp1/pp1/compiled/info_rkt.zo Normal file
View File

Binary file not shown.

1
pp1/pp1/compiled/tests_rkt.dep Normal file
View File

@@ -0,0 +1 @@
("9.1" ta6le ("f4fa2718bf7f743a3c669dae440a3ff3f89eee58" . "738910c444c553415c6d04419abff1a323cb1831") (collects #"r7rs" #"base.rkt") (collects #"r7rs" #"lang" #"reader.rkt") (collects #"r7rs" #"main.rkt") (collects #"r7rs" #"write.rkt") (collects #"racket" #"base.rkt") (collects #"racket" #"main.rkt") (collects #"racket" #"runtime-config.rkt"))

BIN
pp1/pp1/compiled/tests_rkt.zo Normal file
View File

Binary file not shown.

783
pp1/pp1/graphics.rkt Normal file
View File

@@ -0,0 +1,783 @@
#lang racket
;;;;*----------------------------------*;;;;
;;;;* >>> graphics.rkt <<< *;;;;
;;;;* > Programmeerproject 2025-2026 < *;;;;
;;;;* *;;;;
;;;;* >> Versie 2 << *;;;;
;;;;* *;;;;
;;;;* Adapted by: *;;;;
;;;;* Bjarno Oeyen *;;;;
;;;;* Carlos Rojas Castillo *;;;;
;;;;* *;;;;
;;;;* Original implementation by: *;;;;
;;;;* Brecht De Rooms *;;;;
;;;;* Christophe Scholliers *;;;;
;;;;* *;;;;
;;;;* Software Languages Lab *;;;;
;;;;*----------------------------------*;;;;
;; In R5RS projects, include this library using
;; (#%require "Graphics.rkt")
;; In Racket projects, include this library using
;; (require "Graphics.rkt")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(require (only-in compatibility/mlist mlist? list->mlist mlist->list))
;; R5RS's cons-cells are different from Racket's cons-cells... In Racket
;; mutable cons-cells are known as mcons-cells. As this library has been
;; written using Racket, all incoming lists must be converted accordingly.
(require racket/gui/base)
(require racket/string)
(provide make-window
make-tile
make-bitmap-tile
make-tile-sequence
generate-mask)
;;;; --------------------------------------------------------------------- ;;;;
;;;; Note: this is NOT a reference on how to code cleanly. ;;;;
;;;; this code needs to be cleaned up since we mainly did all the ;;;;
;;;; dirty graphics work to achieve a decent drawing efficiency and ;;;;
;;;; to make sure students don't waste time on this. ;;;;
;;;; --------------------------------------------------------------------- ;;;;
;;;;############################### WINDOW #####################################
;;;;---------------------------------------------------------------------
;;;; make-window creates a window that accepts tiles and tile-sequences.
;;;; changing the x-value of a tile will update the canvas.
;;;;---------------------------------------------------------------------
(define default-maximum-fps 60)
(define fps-refresh-time 1000)
(define ignore-held-key #t)
(define default-background-colour "black")
(define (make-window w h title (maximum-fps default-maximum-fps))
(let* ((show-fps #t)
(fps 0)
(fps-accum-dt 0)
(fps-accum-frames 0)
(delta-time 0)
(previous-time (current-milliseconds))
(background-color #f)
;; Define our dummy keyboard-callback
(keyboard-callback (lambda (state key) (void)))
;; Define our dummy update-callback
(update-callback (lambda (ev) (void)))
;; Draw callback
(draw-callback (lambda () (void)))
;; Define our dummy mouse-move-callback
(mouse-move-callback (lambda (x y) (void)))
;; Define our dummy mouse-click-callback
(mouse-click-callback (lambda (btn state x y) (void)))
(game-loop (lambda (deltatime events) (void)))
(game-loop-timer #f)
(layers '())
(background-string "black")
(closed #f))
;; Define the paint-callback which is called each frame
(define (paint-callback canvas dc)
;; before we do anything, the game-loop is executed.
(draw-callback)
;; Set the background colour (once!)
(when background-color
(send dc set-background background-color)
(set! background-color #f))
;; Clear everything on the draw context
(send dc clear)
;; Draw all layers on each frame
(for-each (lambda (layer) ((layer 'draw) dc)) layers)
;; calculate frames per second.
(update-fps! delta-time)
;; Construct the fps string and set the fps in the frame label
(when show-fps
(send frame set-label (construct-fps-string title fps))))
;; Calculate FPS from the time (ms) since last frame
(define (update-fps! dt)
(set! fps-accum-dt (+ fps-accum-dt dt))
(set! fps-accum-frames (+ fps-accum-frames 1))
(when (> fps-accum-dt fps-refresh-time)
(set! fps fps-accum-frames)
(set! fps-accum-frames 0)
(set! fps-accum-dt (- fps-accum-dt fps-refresh-time))))
;; Construct FPS string
(define (construct-fps-string title fps)
(string-append title
" - fps: "
(number->string fps)))
(define keyboard-state (make-hasheq))
(define (handle-keyboard new-state key)
(define old-state (hash-ref keyboard-state key #f))
(if (or (eq? key 'wheel-down)
(eq? key 'wheel-up))
(keyboard-callback new-state key)
(when (or (not (eq? old-state new-state))
(not ignore-held-key))
(hash-set! keyboard-state key new-state)
(keyboard-callback new-state key))))
;; Make a canvas class that uses our own keyboard callback.
(define my-canvas%
(class canvas% ; The base class is canvas%
;; Define overriding method to handle keyboard events
;; this makes sure our own key-callback is called.
(define/override (on-char event)
(define evt (send event get-key-code))
(if (eq? evt 'release)
(handle-keyboard 'released (send event get-key-release-code))
(handle-keyboard 'pressed evt)))
(define/override (on-event event)
;; mouse events
(let* ([type (send event get-event-type)]
[x (send event get-x)]
[y (send event get-y)])
(cond
[(eq? type 'motion) (mouse-move-callback x y)]
[(eq? type 'left-down) (mouse-click-callback 'left 'pressed x y)]
[(eq? type 'left-up) (mouse-click-callback 'left 'released x y)]
[(eq? type 'middle-down) (mouse-click-callback 'middle 'pressed x y)]
[(eq? type 'middle-up) (mouse-click-callback 'middle 'released x y)]
[(eq? type 'right-down) (mouse-click-callback 'right 'pressed x y)]
[(eq? type 'right-up) (mouse-click-callback 'right 'released x y)])))
;; Call the superclass init, passing on all init args
(super-new)))
;; Make a frame class that can react to closing events
(define closing-frame%
(class frame%
(super-new)
(define (on-close)
(set! closed #t))
(augment on-close)))
;; Create frame in which we can place a canvas.
(define frame
(new closing-frame%
[label title]
[width w]
[height h]))
;; Create the canvas with the custom paint-callback
;; This paint-callback is called each time the canvas is refreshed.
;; How fast the canvas is refreshed is handled later.
(define canvas (new my-canvas%
[parent frame]
[paint-callback paint-callback] ))
;; #############################################################
;; ###### public methods for the window ADT ####################
;; #############################################################
;;Create and add layers to the window
(define (new-layer!)
(define layer (make-layer w h canvas))
(set! layers (append layers (list layer)))
layer)
;; Set the backgroudn color of the window
(define (set-background! str)
(set! background-string str)
(set! background-color (make-object color% str)))
;; #############################################################
;; ###### Setting up a self-sustaining game-loop ###############
;; #############################################################
;; Here we handle how fast the canvas is refreshed and thereby how
;; fast paint-callback will be called.
(define (launch-game-loop)
(let* ((min-wait-per-frame 1) ; apparently this has to be at least 1 to avoid locking up.
(ms-per-frame (quotient 1000 maximum-fps))) ; calculate the MINIMUM delta-time in ms between two frames.
;; calculate the min delta-time given the min-wait-per-frame
(define (calculate-interval)
(truncate (max
(- ms-per-frame delta-time)
min-wait-per-frame)))
;; The heart of the self-sustaning loop.
(define (game-loop)
;; get the new delta-time
(set! delta-time (- (current-milliseconds) previous-time))
;; We wait for min-delta-time, which is typically the min-wait-per-frame
(when (>= delta-time ms-per-frame)
;; Perform an update...
(update-callback delta-time)
;; calculate actual delta-time.
(set! previous-time (current-milliseconds))
;; call the canvas refresh which will trigger a paint-callback
(send canvas refresh-now))
(when (not closed)
;; When the game-loop is done we fire the game-loop again
;; after waiting min-delta-time ms, unless the window is closed.
(send game-loop-timer start (calculate-interval) #t)))
;; a timer drives the game-loop which calls the game-loop after waiting
;; 'interval'. A timer normally calls every 'interval' ms but with
;; just-once? #t we prevent that since it will be the game-loop itself
;; that will keep itself alive.
(set! game-loop-timer
(new timer% [notify-callback game-loop]
[interval (calculate-interval) ]
[just-once? #t]))))
(define (adjust-size) ;; Some operating systems do not properly initialise the size of the window. This procedure computes a correction, and applies it
(define-values (size-w size-h) (send frame get-size))
(define-values (client-size-w client-size-h) (send frame get-client-size))
;; (display "user-size: ") (display (list w h)) (newline)
;; (display "window-size: ") (display (list size-w size-h)) (newline)
;; (display "client-size: ") (display (list client-size-w client-size-h)) (newline)
(define correction-w (- w client-size-w))
(define correction-h (- h client-size-h))
;; (display "correction: ") (display (list correction-w correction-h)) (newline)
(send frame resize (+ w correction-w) (+ h correction-h)))
;; dispatch
(define (dispatch-window msg)
(cond ((eq? msg 'new-layer!) new-layer!)
((eq? msg 'set-background!) set-background!)
((eq? msg 'set-key-callback!) (lambda (eh) (set! keyboard-callback eh)))
((eq? msg 'set-update-callback!) (lambda (uc) (set! update-callback uc)))
((eq? msg 'set-draw-callback!) (lambda (dc) (set! draw-callback dc)))
((eq? msg 'set-mouse-click-callback!) (lambda (mc) (set! mouse-click-callback mc)))
((eq? msg 'set-mouse-move-callback!) (lambda (mc) (set! mouse-move-callback mc)))
((eq? msg 'set-title!) (lambda (t) (set! title t)))
((eq? msg 'get-title) title)
((eq? msg 'get-background) background-string)
(else (raise-arguments-error 'window
"wrong message sent"
"message"
msg))))
;; set background
(set-background! default-background-colour)
;; launch the self-sustaining game-loop.
(launch-game-loop)
;; adjust the size of the window
(adjust-size)
;; Show the window
(send frame show #t)
(send canvas focus)
;; Change the mouse event mode
(send frame wheel-event-mode 'one)
dispatch-window))
;;;;################################ GET SPRITES FROM DISK #######################################
;;;;---------------------------------------------------------------------
;;;; make-bitmap creates a bitmap given a path to an image file
;;;; String -> get-bitmap
;;;;---------------------------------------------------------------------
(define (get-bitmap file)
(let ((bitmap (make-object bitmap% 1 1)))
(unless (file-exists? file)
(error 'get-bitmap "Cannot load file path: ~a" file))
(send bitmap load-file file)
bitmap))
;;;;---------------------------------------------------------------------
;;;; make-bitmap creates a bitmap given a path to an image file
;;;; String -> get-bitmap-section
;;;;---------------------------------------------------------------------
(define (get-bitmap-section tilebitmap x y width height)
(define target-bitmap (make-object bitmap% width height))
(define target-dc (new bitmap-dc% [bitmap target-bitmap]))
(send target-dc draw-bitmap-section tilebitmap 0 0 x y width height)
target-bitmap)
;;;;---------------------------------------------------------------------
;;;; generate-mask generates a mask and saves it to disk.
;;;; String, String -> void
;;;;---------------------------------------------------------------------
(define (generate-mask bitmappath background-color)
(when (string? background-color) (set! background-color (send the-color-database find-color background-color)))
(define bitmap (get-bitmap bitmappath))
(define dc (new bitmap-dc% [bitmap bitmap]))
(define white-pixel (make-object color% "white"))
(define black-pixel (make-object color% "black"))
(printf "Generating mask for ~a...~n" bitmappath)
(for ([w (send bitmap get-width)])
(for ([h (send bitmap get-height)])
(define pixel (make-object color%))
(send dc get-pixel w h pixel)
(if (and (= (send background-color red) (send pixel red))
(= (send background-color blue) (send pixel blue))
(= (send background-color green) (send pixel green)))
(send dc set-pixel w h white-pixel)
(send dc set-pixel w h black-pixel))))
(define extension (path-get-extension bitmappath))
(when (not extension) (raise 'unknown-extension))
(define extension-str (bytes->string/utf-8 extension))
(define old-suffix extension-str)
(define new-suffix "_mask.png")
(define maskpath (string-replace bitmappath old-suffix new-suffix))
(printf "Saving mask to ~a...~n" bitmappath)
(define save-result (send (send dc get-bitmap) save-file maskpath 'png))
(when (not save-result) (raise 'save-failed))
(void))
;;;;################################ TILES #######################################
;;;;---------------------------------------------------------------------
;;;; make-bitmap-tile creates a tile from a bitmap with optionally a mask.
;;;; [] mean it is optional.
;;;; String, [String] -> Tile
;;;;---------------------------------------------------------------------
(define (make-bitmap-tile bitmappath [mask #f])
(define bitmap (get-bitmap bitmappath))
(make-tile (send bitmap get-width) (send bitmap get-height) bitmap mask))
;;;;---------------------------------------------------------------------
;;;; make-tile creates a tile from a width and height with optionally
;;;; a bitmap and a mask.
;;;; [] mean it is optional.
;;;; Number, Number, [String, [String]] -> Tile
;;;;---------------------------------------------------------------------
(define (make-tile w h [bitmap #f] [mask #f])
(when (string? bitmap) (set! bitmap (get-bitmap bitmap)))
(when (string? mask) (set! mask (get-bitmap mask)))
(when (not bitmap) (set! bitmap (make-object bitmap% w h #f #t)))
(define bufferbitmap (make-object bitmap% w h #f #t))
(let* ((x 0)
(y 0)
(x-scale 1)
(y-scale 1)
(mask-dc (new bitmap-dc% [bitmap mask]))
(update-callback (lambda () #t))
(bitmap-dc (new bitmap-dc% [bitmap bufferbitmap]))
(rotation 0))
(define (trigger-update!)
(update-callback))
(send bitmap-dc draw-bitmap bitmap 0 0)
;; ##### Drawing methods to draw on the tile yourself.
;; Clear removed your own drawings.
;; void -> void
(define (clear)
(set! bufferbitmap (make-object bitmap% w h #f #t))
(set! bitmap-dc (new bitmap-dc% [bitmap bufferbitmap]))
(send bitmap-dc draw-bitmap bitmap 0 0)
(trigger-update!))
;; Drawing a rectangle
;; Number, Number, Number, Number, (String ∪ Color%) -> void
(define (draw-rectangle x y w h color)
(when (string? color) (set! color (send the-color-database find-color color)))
(send bitmap-dc set-brush color 'solid)
(send bitmap-dc set-pen color 1 'transparent)
(send bitmap-dc draw-rectangle x y w h)
(trigger-update!))
;; Drawing an Ellipse
;; Number, Number, Number, Number, (String ∪ Color%) -> void
(define (draw-ellipse x y w h color)
(when (string? color) (set! color (send the-color-database find-color color)))
(send bitmap-dc set-brush color 'solid)
(send bitmap-dc set-pen color 1 'transparent)
(send bitmap-dc draw-ellipse x y w h)
(trigger-update!))
;; Drawing a Line
;; Number, Number, Number, Number, Number, (String ∪ Color%) -> void
(define (draw-line x y w h width color)
(when (string? color) (set! color (send the-color-database find-color color)))
(send bitmap-dc set-pen color width 'solid)
(send bitmap-dc draw-line x y w h)
(trigger-update!))
;; Drawing Text
;; String, Number, Number, Number, (String ∪ Color%) -> void
(define (draw-text text fontsize x y color)
(when (string? color) (set! color (send the-color-database find-color color)))
(send bitmap-dc set-font (make-object font% fontsize 'default))
(send bitmap-dc set-text-foreground color)
(send bitmap-dc draw-text text x y)
(trigger-update!))
;; Rotation of 90 degrees clockwise.
;; void -> void
(define (rotate-clockwise!)
(rotate! (modulo (+ rotation 90) 360)))
;; Rotation of 90 degrees counterclockwise.
;; void -> void
(define (rotate-counterclockwise!)
(rotate! (modulo (- rotation 90) 360)))
;; Internal Rotation Function with a hack to solve
;; the rather bizar way of rotating in the graphical DrRacket library.
;; void -> void
(define (rotate! r)
(set! rotation r)
(trigger-update!))
;; Set the X position on the screen
;; number -> void
(define (set-x! new-x)
(unless (= x new-x)
(set! x new-x)
(trigger-update!)))
;; Set the Y position on the screen
;; number -> void
(define (set-y! new-y)
(unless (= y new-y)
(set! y new-y)
(trigger-update!)))
(define transparent-color (make-object color% 0 0 0 0))
;; Drawing procedure called by the layer
;; on which the tile is drawn. This should not be called in a student project!
;; dc% -> void
(define (draw dc)
(define offset-x (+ x (/ w 2)))
(define offset-y (+ y (/ h 2)))
(send dc translate offset-x offset-y)
(define rotation-r (/ (* rotation pi) 180))
(send dc rotate rotation-r)
(send dc set-scale x-scale y-scale)
(if mask
(begin (send mask-dc draw-bitmap mask 0 0)
(send dc draw-bitmap bufferbitmap (- (/ w 2)) (- (/ h 2)) 'solid transparent-color mask))
(send dc draw-bitmap bufferbitmap (- (/ w 2)) (- (/ h 2))))
(send dc set-scale 1 1)
(send dc rotate (- rotation-r))
(send dc translate (- offset-x) (- offset-y)))
;; A procedure to set a callback. This callback
;; will notify the parent (layers) that the tile
;; has changed and allows us to automatically
;; redraw the tiles.
;; (void -> void) -> void
(define (set-on-update! new_callback)
(set! update-callback new_callback))
;; Get the scale. If x-scale and y-scale are different, returns the average of the two.
;; void -> number
(define (get-scale)
(if (= x-scale y-scale)
x-scale
(/ (+ x-scale y-scale) 2)))
;; number -> void
(define (set-x-scale! s)
(set! x-scale s))
;; number -> void
(define (set-y-scale! s)
(set! y-scale s))
;; Sets both scales at once.
;; number -> void
(define (set-scale! s)
(set-x-scale! s)
(set-y-scale! s))
;; Dispatch
(define (dispatch-tile msg . args)
(cond
;; Not to be called manually
((eq? msg 'draw) draw)
((eq? msg 'set-on-update!) set-on-update!)
;; Getters and setters
((eq? msg 'set-x!) set-x!)
((eq? msg 'set-y!) set-y!)
((eq? msg 'get-x) x)
((eq? msg 'get-y) y)
((eq? msg 'get-w) w)
((eq? msg 'get-h) h)
;; Rotation
((eq? msg 'get-rotation) rotation)
((eq? msg 'rotate-clockwise!) rotate-clockwise!)
((eq? msg 'rotate-counterclockwise!) rotate-counterclockwise!)
((eq? msg 'rotate!) rotate!)
;; Scale
((eq? msg 'set-x-scale!) set-x-scale!)
((eq? msg 'set-y-scale!) set-y-scale!)
((eq? msg 'set-scale!) set-scale!)
((eq? msg 'get-x-scale) x-scale)
((eq? msg 'get-y-scale) y-scale)
((eq? msg 'get-scale) (get-scale))
;; Clear whatever is on the tile
((eq? msg 'clear!) clear)
;; Drawing
((eq? msg 'draw-rectangle!) draw-rectangle)
((eq? msg 'draw-ellipse!) draw-ellipse)
((eq? msg 'draw-line!) draw-line)
((eq? msg 'draw-text!) draw-text)
;; Error if other message is sent
(else (raise-arguments-error 'tile
"wrong message sent"
"message"
msg))))
dispatch-tile))
;;;;---------------------------------------------------------------------
;;;; tile-sequence is a sequence of tiles, it is created by passing a list
;;;; of tiles to the tile-sequence. A tile-sequence is meant to animate tiles.
;;;; When it is created, the current tile (index) is set on the first tile that
;;;; was added. Calling next will cycle through the tile-sequence and select the
;;;; next tile.
;;;; List<Tile> -> Tile-Sequence
;;;;---------------------------------------------------------------------
(define (make-tile-sequence tiles-in)
;; Initialize the current index and its callback.
(let ((tiles (if (mlist? tiles-in) (mlist->list tiles-in) tiles-in)) ;; converts mutable list (r5rs) to immutable list (Racket).
(index 0)
(update-callback (lambda () #t)))
;; Change its coordiantes on the window
;; Integer -> void
(define (set-x! new-x)
(for-each (lambda (tile) ((tile 'set-x!) new-x)) tiles)
(update-callback))
;; Integer -> void
(define (set-y! new-y)
(for-each (lambda (tile) ((tile 'set-y!) new-y)) tiles)
(update-callback))
;; choose which tile in the sequence is currently active
;; by providing an index.
;; Integer -> void
(define (set-current! new_index)
(if (or (>= new_index (length tiles))
(< new_index 0))
(error 'error "illegal index given for tile-sequence: ~a" new_index)
(begin (set! index new_index)
(update-callback))))
;; Set the previous tile as active tile.
;; void -> void
(define (set-previous!)
(set! index (remainder (- index 1) (length tiles)))
(when (< index 0) (set! index (- (length tiles) 1)))
(update-callback))
;; Set the next tile as active tile.
;; void -> void
(define (set-next!)
(set! index (remainder (+ 1 index) (length tiles)))
(update-callback))
;; Drawing functions, each of them will forward the
;; drawing instruction to the underlying tiles.
;; void -> void
(define (rotate-clockwise!)
(for-each (lambda (tile) (tile 'rotate-clockwise) ) tiles)
(update-callback))
;; void -> void
(define (rotate-counterclockwise!)
(for-each (lambda (tile) (tile 'rotate-counterclockwise) ) tiles)
(update-callback))
;; Number, Number, Number, Number, String -> void
(define (draw-rectangle x y w h color)
(for-each (lambda (tile) ((tile 'draw-rectangle) x y w h color )) tiles)
(update-callback))
;; Number, Number, Number, Number, String -> void
(define (draw-ellipse x y w h color)
(for-each (lambda (tile) ((tile 'draw-ellipse) x y w h color )) tiles)
(update-callback))
;; String, Number, Number, Number, String -> void
(define (draw-text text fontsize x y color)
(for-each (lambda (tile) ((tile 'draw-text) text fontsize x y color )) tiles)
(update-callback))
;; Number, Number, Number, Number, Number, String -> void
(define (draw-line x y w h width color)
(for-each (lambda (tile) ((tile 'draw-line)x y w h width color )) tiles)
(update-callback))
;; Clears everything that is drawn by the user,
;; if there were bitmaps, the bitmaps are restored.
;; void -> void
(define (clear)
(for-each (lambda (tile) (tile 'clear)) tiles)
(update-callback))
;; redraw itself on the provided drawing context
;; void -> void
(define (draw dc)
(((current) 'draw) dc))
;; set update callback which is called every-time a sequence changes
;; (void -> void) -> void
(define (set-on-update! new_callback)
(set! update-callback new_callback))
;; Interal function to retrieve current (private).
;; void -> Tile
(define (current)
(list-ref tiles index))
(define (rotate! d)
(for-each (lambda (tile) ((tile 'rotate!) d)) tiles)
(update-callback))
(define (set-x-scale! s)
(for-each (lambda (tile) ((tile 'set-x-scale!) s)) tiles)
(update-callback))
(define (set-y-scale! s)
(for-each (lambda (tile) ((tile 'set-y-scale!) s)) tiles)
(update-callback))
(define (set-scale! s)
(for-each (lambda (tile) ((tile 'set-scale!) s)) tiles)
(update-callback))
;; Dispatch
(define (dispatch-tile-sequence msg)
(cond
;; Not to be called manually
((eq? msg 'draw) draw)
((eq? msg 'set-on-update!) set-on-update!)
;; Moving and dimension and position getters.
((eq? msg 'set-x!) set-x!)
((eq? msg 'set-y!) set-y!)
((eq? msg 'get-x) (lambda () ((current) 'get-x)))
((eq? msg 'get-y) (lambda () ((current) 'get-y)))
((eq? msg 'get-w) (lambda () ((current) 'get-w)))
((eq? msg 'get-h) (lambda () ((current) 'get-h)))
;; Animations to switch between tiles
((eq? msg 'set-current!) set-current!)
((eq? msg 'get-current) index)
((eq? msg 'set-next!) set-next!)
((eq? msg 'set-previous!) set-previous!)
;; Rotation manipulations
((eq? msg 'rotate-clockwise!) rotate-clockwise!)
((eq? msg 'rotate-counterclockwise!) rotate-counterclockwise!)
;; Clear all manual drawings
((eq? msg 'clear!) clear)
;; Rotation
((eq? msg 'get-rotation) (lambda () ((current) 'get-rotation)))
((eq? msg 'rotate!) rotate!)
;; Scale
((eq? msg 'set-x-scale!) set-x-scale!)
((eq? msg 'set-y-scale!) set-y-scale!)
((eq? msg 'set-scale!) set-scale!)
((eq? msg 'get-x-scale) (lambda () ((current) 'get-x-scale)))
((eq? msg 'get-y-scale) (lambda () ((current) 'get-y-scale)))
((eq? msg 'get-scale) (lambda () ((current) 'get-scale)))
;; Create manual drawings
((eq? msg 'draw-rectangle!) draw-rectangle)
((eq? msg 'draw-ellipse!) draw-ellipse)
((eq? msg 'draw-line!) draw-line)
((eq? msg 'draw-text!) draw-text)
;; Error
(else (raise-arguments-error 'tile-sequence
"wrong message sent"
"message"
msg))))
dispatch-tile-sequence))
;;;;################################ LAYER #######################################
;;;;---------------------------------------------------------------------
;;;; layers in a window, each layer has a temporary bitmap.
;;;; Integer Integer canvas% -> Layer
;;;;---------------------------------------------------------------------
(define (make-layer w h canvas)
(let* ((drawables '()) ;; all drawables on this layer.
(bitmap (make-object bitmap% w h #f #t )) ;; buffer-bitmap for fast drawing
(bitmap-dc (new bitmap-dc% [bitmap bitmap])) ;; dc of bitmap (drawing context)
(needs-update #t)) ;; even faster drawing thanks to dirty bit.
;; redraw on temporary bitmap layer.
;; void -> void
(define (redraw)
(send bitmap-dc erase)
;; This will redraw all drawables on the layer
;; Therefore it is not wise to put one moving object together with a bunch
;; of non-moving objects on ONE layer.
(for-each (lambda (tile) ((tile 'draw) bitmap-dc)) drawables))
;; draw itself on given drawing context.
;; dc% -> void
(define (draw dc)
(when needs-update
(redraw)
(set! needs-update #f))
(send dc draw-bitmap bitmap 0 0))
;; Adds a drawable to the layer which is a tile a tile-sequence or
;; a drawable created by the student which suports 'draw' and 'set-on-update!'
;; (Tile ∪ Tile-Sequence) -> void
(define (add-drawable drawable)
((drawable 'set-on-update!) (lambda () (set! needs-update #t)))
(set! drawables (cons drawable drawables))
(set! needs-update #t))
;; Remove a drawable to the layer which is a tile a tile-sequence or
;; a drawable created by the student which suports 'draw' and 'set-on-update!'
;; (Tile ∪ Tile-Sequence) -> void
(define (remove-drawable drawable)
((drawable 'set-on-update!) (lambda () #t))
(set! drawables (remq drawable drawables))
(set! needs-update #t))
;; Removes all drawables from a single layer.
;; void -> void
(define (empty!)
(for-each remove-drawable drawables))
;; # dispatch
(define (dispatch-layer msg)
(cond ((eq? msg 'add-drawable!) add-drawable)
((eq? msg 'remove-drawable!) remove-drawable)
((eq? msg 'empty!) empty!)
((eq? msg 'draw) draw)
(else (raise-arguments-error 'layer
"wrong message sent"
"message"
msg))))
dispatch-layer))

783
pp1/pp1/graphics.rkt~ Normal file
View File

@@ -0,0 +1,783 @@
#lang racket
;;;;*----------------------------------*;;;;
;;;;* >>> graphics.rkt <<< *;;;;
;;;;* > Programmeerproject 2025-2026 < *;;;;
;;;;* *;;;;
;;;;* >> Versie 2 << *;;;;
;;;;* *;;;;
;;;;* Adapted by: *;;;;
;;;;* Bjarno Oeyen *;;;;
;;;;* Carlos Rojas Castillo *;;;;
;;;;* *;;;;
;;;;* Original implementation by: *;;;;
;;;;* Brecht De Rooms *;;;;
;;;;* Christophe Scholliers *;;;;
;;;;* *;;;;
;;;;* Software Languages Lab *;;;;
;;;;*----------------------------------*;;;;
;; In R5RS projects, include this library using
;; (#%require "Graphics.rkt")
;; In Racket projects, include this library using
;; (require "Graphics.rkt")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(require (only-in compatibility/mlist mlist? list->mlist mlist->list))
;; R5RS's cons-cells are different from Racket's cons-cells... In Racket
;; mutable cons-cells are known as mcons-cells. As this library has been
;; written using Racket, all incoming lists must be converted accordingly.
(require racket/gui/base)
(require racket/string)
(provide make-window
make-tile
make-bitmap-tile
make-tile-sequence
generate-mask)
;;;; --------------------------------------------------------------------- ;;;;
;;;; Note: this is NOT a reference on how to code cleanly. ;;;;
;;;; this code needs to be cleaned up since we mainly did all the ;;;;
;;;; dirty graphics work to achieve a decent drawing efficiency and ;;;;
;;;; to make sure students don't waste time on this. ;;;;
;;;; --------------------------------------------------------------------- ;;;;
;;;;############################### WINDOW #####################################
;;;;---------------------------------------------------------------------
;;;; make-window creates a window that accepts tiles and tile-sequences.
;;;; changing the x-value of a tile will update the canvas.
;;;;---------------------------------------------------------------------
(define default-maximum-fps 60)
(define fps-refresh-time 1000)
(define ignore-held-key #t)
(define default-background-colour "black")
(define (make-window w h title (maximum-fps default-maximum-fps))
(let* ((show-fps #t)
(fps 0)
(fps-accum-dt 0)
(fps-accum-frames 0)
(delta-time 0)
(previous-time (current-milliseconds))
(background-color #f)
;; Define our dummy keyboard-callback
(keyboard-callback (lambda (state key) (void)))
;; Define our dummy update-callback
(update-callback (lambda (ev) (void)))
;; Draw callback
(draw-callback (lambda () (void)))
;; Define our dummy mouse-move-callback
(mouse-move-callback (lambda (x y) (void)))
;; Define our dummy mouse-click-callback
(mouse-click-callback (lambda (btn state x y) (void)))
(game-loop (lambda (deltatime events) (void)))
(game-loop-timer #f)
(layers '())
(background-string "black")
(closed #f))
;; Define the paint-callback which is called each frame
(define (paint-callback canvas dc)
;; before we do anything, the game-loop is executed.
(draw-callback)
;; Set the background colour (once!)
(when background-color
(send dc set-background background-color)
(set! background-color #f))
;; Clear everything on the draw context
(send dc clear)
;; Draw all layers on each frame
(for-each (lambda (layer) ((layer 'draw) dc)) layers)
;; calculate frames per second.
(update-fps! delta-time)
;; Construct the fps string and set the fps in the frame label
(when show-fps
(send frame set-label (construct-fps-string title fps))))
;; Calculate FPS from the time (ms) since last frame
(define (update-fps! dt)
(set! fps-accum-dt (+ fps-accum-dt dt))
(set! fps-accum-frames (+ fps-accum-frames 1))
(when (> fps-accum-dt fps-refresh-time)
(set! fps fps-accum-frames)
(set! fps-accum-frames 0)
(set! fps-accum-dt (- fps-accum-dt fps-refresh-time))))
;; Construct FPS string
(define (construct-fps-string title fps)
(string-append title
" - fps: "
(number->string fps)))
(define keyboard-state (make-hasheq))
(define (handle-keyboard new-state key)
(define old-state (hash-ref keyboard-state key #f))
(if (or (eq? key 'wheel-down)
(eq? key 'wheel-up))
(keyboard-callback new-state key)
(when (or (not (eq? old-state new-state))
(not ignore-held-key))
(hash-set! keyboard-state key new-state)
(keyboard-callback new-state key))))
;; Make a canvas class that uses our own keyboard callback.
(define my-canvas%
(class canvas% ; The base class is canvas%
;; Define overriding method to handle keyboard events
;; this makes sure our own key-callback is called.
(define/override (on-char event)
(define evt (send event get-key-code))
(if (eq? evt 'release)
(handle-keyboard 'released (send event get-key-release-code))
(handle-keyboard 'pressed evt)))
(define/override (on-event event)
;; mouse events
(let* ([type (send event get-event-type)]
[x (send event get-x)]
[y (send event get-y)])
(cond
[(eq? type 'motion) (mouse-move-callback x y)]
[(eq? type 'left-down) (mouse-click-callback 'left 'pressed x y)]
[(eq? type 'left-up) (mouse-click-callback 'left 'released x y)]
[(eq? type 'middle-down) (mouse-click-callback 'middle 'pressed x y)]
[(eq? type 'middle-up) (mouse-click-callback 'middle 'released x y)]
[(eq? type 'right-down) (mouse-click-callback 'right 'pressed x y)]
[(eq? type 'right-up) (mouse-click-callback 'right 'released x y)])))
;; Call the superclass init, passing on all init args
(super-new)))
;; Make a frame class that can react to closing events
(define closing-frame%
(class frame%
(super-new)
(define (on-close)
(set! closed #t))
(augment on-close)))
;; Create frame in which we can place a canvas.
(define frame
(new closing-frame%
[label title]
[width w]
[height h]))
;; Create the canvas with the custom paint-callback
;; This paint-callback is called each time the canvas is refreshed.
;; How fast the canvas is refreshed is handled later.
(define canvas (new my-canvas%
[parent frame]
[paint-callback paint-callback] ))
;; #############################################################
;; ###### public methods for the window ADT ####################
;; #############################################################
;;Create and add layers to the window
(define (new-layer!)
(define layer (make-layer w h canvas))
(set! layers (append layers (list layer)))
layer)
;; Set the backgroudn color of the window
(define (set-background! str)
(set! background-string str)
(set! background-color (make-object color% str)))
;; #############################################################
;; ###### Setting up a self-sustaining game-loop ###############
;; #############################################################
;; Here we handle how fast the canvas is refreshed and thereby how
;; fast paint-callback will be called.
(define (launch-game-loop)
(let* ((min-wait-per-frame 1) ; apparently this has to be at least 1 to avoid locking up.
(ms-per-frame (quotient 1000 maximum-fps))) ; calculate the MINIMUM delta-time in ms between two frames.
;; calculate the min delta-time given the min-wait-per-frame
(define (calculate-interval)
(truncate (max
(- ms-per-frame delta-time)
min-wait-per-frame)))
;; The heart of the self-sustaning loop.
(define (game-loop)
;; get the new delta-time
(set! delta-time (- (current-milliseconds) previous-time))
;; We wait for min-delta-time, which is typically the min-wait-per-frame
(when (>= delta-time ms-per-frame)
;; Perform an update...
(update-callback delta-time)
;; calculate actual delta-time.
(set! previous-time (current-milliseconds))
;; call the canvas refresh which will trigger a paint-callback
(send canvas refresh-now))
(when (not closed)
;; When the game-loop is done we fire the game-loop again
;; after waiting min-delta-time ms, unless the window is closed.
(send game-loop-timer start (calculate-interval) #t)))
;; a timer drives the game-loop which calls the game-loop after waiting
;; 'interval'. A timer normally calls every 'interval' ms but with
;; just-once? #t we prevent that since it will be the game-loop itself
;; that will keep itself alive.
(set! game-loop-timer
(new timer% [notify-callback game-loop]
[interval (calculate-interval) ]
[just-once? #t]))))
(define (adjust-size) ;; Some operating systems do not properly initialise the size of the window. This procedure computes a correction, and applies it
(define-values (size-w size-h) (send frame get-size))
(define-values (client-size-w client-size-h) (send frame get-client-size))
;; (display "user-size: ") (display (list w h)) (newline)
;; (display "window-size: ") (display (list size-w size-h)) (newline)
;; (display "client-size: ") (display (list client-size-w client-size-h)) (newline)
(define correction-w (- w client-size-w))
(define correction-h (- h client-size-h))
;; (display "correction: ") (display (list correction-w correction-h)) (newline)
(send frame resize (+ w correction-w) (+ h correction-h)))
;; dispatch
(define (dispatch-window msg)
(cond ((eq? msg 'new-layer!) new-layer!)
((eq? msg 'set-background!) set-background!)
((eq? msg 'set-key-callback!) (lambda (eh) (set! keyboard-callback eh)))
((eq? msg 'set-update-callback!) (lambda (uc) (set! update-callback uc)))
((eq? msg 'set-draw-callback!) (lambda (dc) (set! draw-callback dc)))
((eq? msg 'set-mouse-click-callback!) (lambda (mc) (set! mouse-click-callback mc)))
((eq? msg 'set-mouse-move-callback!) (lambda (mc) (set! mouse-move-callback mc)))
((eq? msg 'set-title!) (lambda (t) (set! title t)))
((eq? msg 'get-title) title)
((eq? msg 'get-background) background-string)
(else (raise-arguments-error 'window
"wrong message sent"
"message"
msg))))
;; set background
(set-background! default-background-colour)
;; launch the self-sustaining game-loop.
(launch-game-loop)
;; adjust the size of the window
(adjust-size)
;; Show the window
(send frame show #t)
(send canvas focus)
;; Change the mouse event mode
(send frame wheel-event-mode 'one)
dispatch-window))
;;;;################################ GET SPRITES FROM DISK #######################################
;;;;---------------------------------------------------------------------
;;;; make-bitmap creates a bitmap given a path to an image file
;;;; String -> get-bitmap
;;;;---------------------------------------------------------------------
(define (get-bitmap file)
(let ((bitmap (make-object bitmap% 1 1)))
(unless (file-exists? file)
(error 'get-bitmap "Cannot load file path: ~a" file))
(send bitmap load-file file)
bitmap))
;;;;---------------------------------------------------------------------
;;;; make-bitmap creates a bitmap given a path to an image file
;;;; String -> get-bitmap-section
;;;;---------------------------------------------------------------------
(define (get-bitmap-section tilebitmap x y width height)
(define target-bitmap (make-object bitmap% width height))
(define target-dc (new bitmap-dc% [bitmap target-bitmap]))
(send target-dc draw-bitmap-section tilebitmap 0 0 x y width height)
target-bitmap)
;;;;---------------------------------------------------------------------
;;;; generate-mask generates a mask and saves it to disk.
;;;; String, String -> void
;;;;---------------------------------------------------------------------
(define (generate-mask bitmappath background-color)
(when (string? background-color) (set! background-color (send the-color-database find-color background-color)))
(define bitmap (get-bitmap bitmappath))
(define dc (new bitmap-dc% [bitmap bitmap]))
(define white-pixel (make-object color% "white"))
(define black-pixel (make-object color% "black"))
(printf "Generating mask for ~a...~n" bitmappath)
(for ([w (send bitmap get-width)])
(for ([h (send bitmap get-height)])
(define pixel (make-object color%))
(send dc get-pixel w h pixel)
(if (and (= (send background-color red) (send pixel red))
(= (send background-color blue) (send pixel blue))
(= (send background-color green) (send pixel green)))
(send dc set-pixel w h white-pixel)
(send dc set-pixel w h black-pixel))))
(define extension (path-get-extension bitmappath))
(when (not extension) (raise 'unknown-extension))
(define extension-str (bytes->string/utf-8 extension))
(define old-suffix extension-str)
(define new-suffix "_mask.png")
(define maskpath (string-replace bitmappath old-suffix new-suffix))
(printf "Saving mask to ~a...~n" bitmappath)
(define save-result (send (send dc get-bitmap) save-file maskpath 'png))
(when (not save-result) (raise 'save-failed))
(void))
;;;;################################ TILES #######################################
;;;;---------------------------------------------------------------------
;;;; make-bitmap-tile creates a tile from a bitmap with optionally a mask.
;;;; [] mean it is optional.
;;;; String, [String] -> Tile
;;;;---------------------------------------------------------------------
(define (make-bitmap-tile bitmappath [mask #f])
(define bitmap (get-bitmap bitmappath))
(make-tile (send bitmap get-width) (send bitmap get-height) bitmap mask))
;;;;---------------------------------------------------------------------
;;;; make-tile creates a tile from a width and height with optionally
;;;; a bitmap and a mask.
;;;; [] mean it is optional.
;;;; Number, Number, [String, [String]] -> Tile
;;;;---------------------------------------------------------------------
(define (make-tile w h [bitmap #f] [mask #f])
(when (string? bitmap) (set! bitmap (get-bitmap bitmap)))
(when (string? mask) (set! mask (get-bitmap mask)))
(when (not bitmap) (set! bitmap (make-object bitmap% w h #f #t)))
(define bufferbitmap (make-object bitmap% w h #f #t))
(let* ((x 0)
(y 0)
(x-scale 1)
(y-scale 1)
(mask-dc (new bitmap-dc% [bitmap mask]))
(update-callback (lambda () #t))
(bitmap-dc (new bitmap-dc% [bitmap bufferbitmap]))
(rotation 0))
(define (trigger-update!)
(update-callback))
(send bitmap-dc draw-bitmap bitmap 0 0)
;; ##### Drawing methods to draw on the tile yourself.
;; Clear removed your own drawings.
;; void -> void
(define (clear)
(set! bufferbitmap (make-object bitmap% w h #f #t))
(set! bitmap-dc (new bitmap-dc% [bitmap bufferbitmap]))
(send bitmap-dc draw-bitmap bitmap 0 0)
(trigger-update!))
;; Drawing a rectangle
;; Number, Number, Number, Number, (String ∪ Color%) -> void
(define (draw-rectangle x y w h color)
(when (string? color) (set! color (send the-color-database find-color color)))
(send bitmap-dc set-brush color 'solid)
(send bitmap-dc set-pen color 1 'transparent)
(send bitmap-dc draw-rectangle x y w h)
(trigger-update!))
;; Drawing an Ellipse
;; Number, Number, Number, Number, (String ∪ Color%) -> void
(define (draw-ellipse x y w h color)
(when (string? color) (set! color (send the-color-database find-color color)))
(send bitmap-dc set-brush color 'solid)
(send bitmap-dc set-pen color 1 'transparent)
(send bitmap-dc draw-ellipse x y w h)
(trigger-update!))
;; Drawing a Line
;; Number, Number, Number, Number, Number, (String ∪ Color%) -> void
(define (draw-line x y w h width color)
(when (string? color) (set! color (send the-color-database find-color color)))
(send bitmap-dc set-pen color width 'solid)
(send bitmap-dc draw-line x y w h)
(trigger-update!))
;; Drawing Text
;; String, Number, Number, Number, (String ∪ Color%) -> void
(define (draw-text text fontsize x y color)
(when (string? color) (set! color (send the-color-database find-color color)))
(send bitmap-dc set-font (make-object font% fontsize 'default))
(send bitmap-dc set-text-foreground color)
(send bitmap-dc draw-text text x y)
(trigger-update!))
;; Rotation of 90 degrees clockwise.
;; void -> void
(define (rotate-clockwise!)
(rotate! (modulo (+ rotation 90) 360)))
;; Rotation of 90 degrees counterclockwise.
;; void -> void
(define (rotate-counterclockwise!)
(rotate! (modulo (- rotation 90) 360)))
;; Internal Rotation Function with a hack to solve
;; the rather bizar way of rotating in the graphical DrRacket library.
;; void -> void
(define (rotate! r)
(set! rotation r)
(trigger-update!))
;; Set the X position on the screen
;; number -> void
(define (set-x! new-x)
(unless (= x new-x)
(set! x new-x)
(trigger-update!)))
;; Set the Y position on the screen
;; number -> void
(define (set-y! new-y)
(unless (= y new-y)
(set! y new-y)
(trigger-update!)))
(define transparent-color (make-object color% 0 0 0 0))
;; Drawing procedure called by the layer
;; on which the tile is drawn. This should not be called in a student project!
;; dc% -> void
(define (draw dc)
(define offset-x (+ x (/ w 2)))
(define offset-y (+ y (/ h 2)))
(send dc translate offset-x offset-y)
(define rotation-r (/ (* rotation pi) 180))
(send dc rotate rotation-r)
(send dc set-scale x-scale y-scale)
(if mask
(begin (send mask-dc draw-bitmap mask 0 0)
(send dc draw-bitmap bufferbitmap (- (/ w 2)) (- (/ h 2)) 'solid transparent-color mask))
(send dc draw-bitmap bufferbitmap (- (/ w 2)) (- (/ h 2))))
(send dc set-scale 1 1)
(send dc rotate (- rotation-r))
(send dc translate (- offset-x) (- offset-y)))
;; A procedure to set a callback. This callback
;; will notify the parent (layers) that the tile
;; has changed and allows us to automatically
;; redraw the tiles.
;; (void -> void) -> void
(define (set-on-update! new_callback)
(set! update-callback new_callback))
;; Get the scale. If x-scale and y-scale are different, returns the average of the two.
;; void -> number
(define (get-scale)
(if (= x-scale y-scale)
x-scale
(/ (+ x-scale y-scale) 2)))
;; number -> void
(define (set-x-scale! s)
(set! x-scale s))
;; number -> void
(define (set-y-scale! s)
(set! y-scale s))
;; Sets both scales at once.
;; number -> void
(define (set-scale! s)
(set-x-scale! s)
(set-y-scale! s))
;; Dispatch
(define (dispatch-tile msg . args)
(cond
;; Not to be called manually
((eq? msg 'draw) draw)
((eq? msg 'set-on-update!) set-on-update!)
;; Getters and setters
((eq? msg 'set-x!) set-x!)
((eq? msg 'set-y!) set-y!)
((eq? msg 'get-x) x)
((eq? msg 'get-y) y)
((eq? msg 'get-w) w)
((eq? msg 'get-h) h)
;; Rotation
((eq? msg 'get-rotation) rotation)
((eq? msg 'rotate-clockwise!) rotate-clockwise!)
((eq? msg 'rotate-counterclockwise!) rotate-counterclockwise!)
((eq? msg 'rotate!) rotate!)
;; Scale
((eq? msg 'set-x-scale!) set-x-scale!)
((eq? msg 'set-y-scale!) set-y-scale!)
((eq? msg 'set-scale!) set-scale!)
((eq? msg 'get-x-scale) x-scale)
((eq? msg 'get-y-scale) y-scale)
((eq? msg 'get-scale) (get-scale))
;; Clear whatever is on the tile
((eq? msg 'clear!) clear)
;; Drawing
((eq? msg 'draw-rectangle!) draw-rectangle)
((eq? msg 'draw-ellipse!) draw-ellipse)
((eq? msg 'draw-line!) draw-line)
((eq? msg 'draw-text!) draw-text)
;; Error if other message is sent
(else (raise-arguments-error 'tile
"wrong message sent"
"message"
msg))))
dispatch-tile))
;;;;---------------------------------------------------------------------
;;;; tile-sequence is a sequence of tiles, it is created by passing a list
;;;; of tiles to the tile-sequence. A tile-sequence is meant to animate tiles.
;;;; When it is created, the current tile (index) is set on the first tile that
;;;; was added. Calling next will cycle through the tile-sequence and select the
;;;; next tile.
;;;; List<Tile> -> Tile-Sequence
;;;;---------------------------------------------------------------------
(define (make-tile-sequence tiles-in)
;; Initialize the current index and its callback.
(let ((tiles (if (mlist? tiles-in) (mlist->list tiles-in) tiles-in)) ;; converts mutable list (r5rs) to immutable list (Racket).
(index 0)
(update-callback (lambda () #t)))
;; Change its coordiantes on the window
;; Integer -> void
(define (set-x! new-x)
(for-each (lambda (tile) ((tile 'set-x!) new-x)) tiles)
(update-callback))
;; Integer -> void
(define (set-y! new-y)
(for-each (lambda (tile) ((tile 'set-y!) new-y)) tiles)
(update-callback))
;; choose which tile in the sequence is currently active
;; by providing an index.
;; Integer -> void
(define (set-current! new_index)
(if (or (>= new_index (length tiles))
(< new_index 0))
(error 'error "illegal index given for tile-sequence: ~a" new_index)
(begin (set! index new_index)
(update-callback))))
;; Set the previous tile as active tile.
;; void -> void
(define (set-previous!)
(set! index (remainder (- index 1) (length tiles)))
(when (< index 0) (set! index (- (length tiles) 1)))
(update-callback))
;; Set the next tile as active tile.
;; void -> void
(define (set-next!)
(set! index (remainder (+ 1 index) (length tiles)))
(update-callback))
;; Drawing functions, each of them will forward the
;; drawing instruction to the underlying tiles.
;; void -> void
(define (rotate-clockwise!)
(for-each (lambda (tile) (tile 'rotate-clockwise) ) tiles)
(update-callback))
;; void -> void
(define (rotate-counterclockwise!)
(for-each (lambda (tile) (tile 'rotate-counterclockwise) ) tiles)
(update-callback))
;; Number, Number, Number, Number, String -> void
(define (draw-rectangle x y w h color)
(for-each (lambda (tile) ((tile 'draw-rectangle) x y w h color )) tiles)
(update-callback))
;; Number, Number, Number, Number, String -> void
(define (draw-ellipse x y w h color)
(for-each (lambda (tile) ((tile 'draw-ellipse) x y w h color )) tiles)
(update-callback))
;; String, Number, Number, Number, String -> void
(define (draw-text text fontsize x y color)
(for-each (lambda (tile) ((tile 'draw-text) text fontsize x y color )) tiles)
(update-callback))
;; Number, Number, Number, Number, Number, String -> void
(define (draw-line x y w h width color)
(for-each (lambda (tile) ((tile 'draw-line)x y w h width color )) tiles)
(update-callback))
;; Clears everything that is drawn by the user,
;; if there were bitmaps, the bitmaps are restored.
;; void -> void
(define (clear)
(for-each (lambda (tile) (tile 'clear)) tiles)
(update-callback))
;; redraw itself on the provided drawing context
;; void -> void
(define (draw dc)
(((current) 'draw) dc))
;; set update callback which is called every-time a sequence changes
;; (void -> void) -> void
(define (set-on-update! new_callback)
(set! update-callback new_callback))
;; Interal function to retrieve current (private).
;; void -> Tile
(define (current)
(list-ref tiles index))
(define (rotate! d)
(for-each (lambda (tile) ((tile 'rotate!) d)) tiles)
(update-callback))
(define (set-x-scale! s)
(for-each (lambda (tile) ((tile 'set-x-scale!) s)) tiles)
(update-callback))
(define (set-y-scale! s)
(for-each (lambda (tile) ((tile 'set-y-scale!) s)) tiles)
(update-callback))
(define (set-scale! s)
(for-each (lambda (tile) ((tile 'set-scale!) s)) tiles)
(update-callback))
;; Dispatch
(define (dispatch-tile-sequence msg)
(cond
;; Not to be called manually
((eq? msg 'draw) draw)
((eq? msg 'set-on-update!) set-on-update!)
;; Moving and dimension and position getters.
((eq? msg 'set-x!) set-x!)
((eq? msg 'set-y!) set-y!)
((eq? msg 'get-x) (lambda () ((current) 'get-x)))
((eq? msg 'get-y) (lambda () ((current) 'get-y)))
((eq? msg 'get-w) (lambda () ((current) 'get-w)))
((eq? msg 'get-h) (lambda () ((current) 'get-h)))
;; Animations to switch between tiles
((eq? msg 'set-current!) set-current!)
((eq? msg 'get-current) index)
((eq? msg 'set-next!) set-next!)
((eq? msg 'set-previous!) set-previous!)
;; Rotation manipulations
((eq? msg 'rotate-clockwise!) rotate-clockwise!)
((eq? msg 'rotate-counterclockwise!) rotate-counterclockwise!)
;; Clear all manual drawings
((eq? msg 'clear!) clear)
;; Rotation
((eq? msg 'get-rotation) (lambda () ((current) 'get-rotation)))
((eq? msg 'rotate!) rotate!)
;; Scale
((eq? msg 'set-x-scale!) set-x-scale!)
((eq? msg 'set-y-scale!) set-y-scale!)
((eq? msg 'set-scale!) set-scale!)
((eq? msg 'get-x-scale) (lambda () ((current) 'get-x-scale)))
((eq? msg 'get-y-scale) (lambda () ((current) 'get-y-scale)))
((eq? msg 'get-scale) (lambda () ((current) 'get-scale)))
;; Create manual drawings
((eq? msg 'draw-rectangle!) draw-rectangle)
((eq? msg 'draw-ellipse!) draw-ellipse)
((eq? msg 'draw-line!) draw-line)
((eq? msg 'draw-text!) draw-text)
;; Error
(else (raise-arguments-error 'tile-sequence
"wrong message sent"
"message"
msg))))
dispatch-tile-sequence))
;;;;################################ LAYER #######################################
;;;;---------------------------------------------------------------------
;;;; layers in a window, each layer has a temporary bitmap.
;;;; Integer Integer canvas% -> Layer
;;;;---------------------------------------------------------------------
(define (make-layer w h canvas)
(let* ((drawables '()) ;; all drawables on this layer.
(bitmap (make-object bitmap% w h #f #t )) ;; buffer-bitmap for fast drawing
(bitmap-dc (new bitmap-dc% [bitmap bitmap])) ;; dc of bitmap (drawing context)
(needs-update #t)) ;; even faster drawing thanks to dirty bit.
;; redraw on temporary bitmap layer.
;; void -> void
(define (redraw)
(send bitmap-dc erase)
;; This will redraw all drawables on the layer
;; Therefore it is not wise to put one moving object together with a bunch
;; of non-moving objects on ONE layer.
(for-each (lambda (tile) ((tile 'draw) bitmap-dc)) drawables))
;; draw itself on given drawing context.
;; dc% -> void
(define (draw dc)
(when needs-update
(redraw)
(set! needs-update #f))
(send dc draw-bitmap bitmap 0 0))
;; Adds a drawable to the layer which is a tile a tile-sequence or
;; a drawable created by the student which suports 'draw' and 'set-on-update!'
;; (Tile ∪ Tile-Sequence) -> void
(define (add-drawable drawable)
((drawable 'set-on-update!) (lambda () (set! needs-update #t)))
(set! drawables (cons drawable drawables))
(set! needs-update #t))
;; Remove a drawable to the layer which is a tile a tile-sequence or
;; a drawable created by the student which suports 'draw' and 'set-on-update!'
;; (Tile ∪ Tile-Sequence) -> void
(define (remove-drawable drawable)
((drawable 'set-on-update!) (lambda () #t))
(set! drawables (remq drawable drawables))
(set! needs-update #t))
;; Removes all drawables from a single layer.
;; void -> void
(define (empty!)
(for-each remove-drawable drawables))
;; # dispatch
(define (dispatch-layer msg)
(cond ((eq? msg 'add-drawable!) add-drawable)
((eq? msg 'remove-drawable!) remove-drawable)
((eq? msg 'empty!) empty!)
((eq? msg 'draw) draw)
(else (raise-arguments-error 'layer
"wrong message sent"
"message"
msg))))
dispatch-layer))

2
pp1/pp1/info.rkt Normal file
View File

@@ -0,0 +1,2 @@
#lang info
(define name "pp1")

97
pp1/pp1/tests.rkt Normal file
View File

@@ -0,0 +1,97 @@
#lang r7rs
;;;;*----------------------------------*;;;;
;;;;* >>> tests.rkt <<< *;;;;
;;;;* > Programmeerproject 2025-2026 < *;;;;
;;;;* *;;;;
;;;;* >> Versie 2 << *;;;;
;;;;* *;;;;
;;;;* Design and Implementation: *;;;;
;;;;* Bjarno Oeyen *;;;;
;;;;* *;;;;
;;;;* Software Languages Lab *;;;;
;;;;*----------------------------------*;;;;
(define-library ()
(import (scheme base)
(scheme write)
(only (racket) format))
(export run-test check
make-check-predicate make-check-predicate-not
check-= check-eq? check-eqv? check-equal?
check-not-= check-not-eq? check-not-eqv? check-not-equal?)
(begin
(define (run-test . args)
(define test-name #f)
(define proc #f)
(cond
((= (length args) 1) (set! proc (car args))
(set! test-name "Anonymous test"))
((= (length args) 2)
(if (string? (car args))
(let ()
(set! proc (cadr args))
(set! test-name (car args)))
(let ()
(set! proc (car args))
(set! test-name (cadr args)))))
(else
(raise "Unexpected number of arguments for run-test")))
(let ()
(define test-result
(call-with-current-continuation
(lambda (k)
(with-exception-handler
(lambda (x)
(k `(exception ,x)))
(lambda ()
(let ((value (proc)))
(if value
(k `(success ,value))
(k `(failure ,value)))))))))
(define result (car test-result))
(define value (cadr test-result))
(define line "--------------------------------------------------------------------------------\n")
(cond
((eq? result 'exception)
(display (format "~a[TEST] ~a FAILURE!~n~a~n~a~n" line test-name value line)))
((eq? result 'success)
(display (format "[TEST] ~a SUCCESS!~n" test-name)))
((eq? result 'failure)
(display (format "[TEST] ~a: FAILURE! (returned #f)~n" test-name))))))
(define (check condition . msg)
(if condition
#t
(if (null? msg)
(raise "Reason: Check failed!")
(raise (format "Reason: Check failed!~n~a" (car msg))))))
(define (make-check-predicate pred)
(lambda (actual expected . args)
(define internal-msg (if (null? args) #f (car args)))
(check (pred expected actual)
(if internal-msg
(format "Message: ~a~nExpected: ~a~nActual: ~a" internal-msg expected actual)
(format "Expected: ~a~nActual: ~a" expected actual)))))
(define (make-check-predicate-not pred)
(lambda (actual expected . args)
(define internal-msg (if (null? args) #f (car args)))
(check (not (pred expected actual))
(if internal-msg
(format "Message: ~a~nActual value should be different from ~a" internal-msg expected)
(format "Actual value should be different from ~a" expected)))))
(define check-= (make-check-predicate =))
(define check-eq? (make-check-predicate eq?))
(define check-eqv? (make-check-predicate eqv?))
(define check-equal? (make-check-predicate equal?))
(define check-not-= (make-check-predicate-not =))
(define check-not-eq? (make-check-predicate-not eq?))
(define check-not-eqv? (make-check-predicate-not eqv?))
(define check-not-equal? (make-check-predicate-not equal?))
))