commit 3abc9aae5563e24a3082a906c5a25111eb31f031 Author: joren Date: Mon Mar 23 10:28:54 2026 +0100 first commit diff --git a/README.md b/README.md new file mode 100644 index 0000000..e69de29 diff --git a/pacman-project/.DS_Store b/pacman-project/.DS_Store new file mode 100644 index 0000000..311e29b Binary files /dev/null and b/pacman-project/.DS_Store differ diff --git "a/pacman-project/Icon\r" "b/pacman-project/Icon\r" new file mode 100644 index 0000000..e69de29 diff --git a/pacman-project/coin.rkt b/pacman-project/coin.rkt new file mode 100644 index 0000000..c08943c --- /dev/null +++ b/pacman-project/coin.rkt @@ -0,0 +1,39 @@ +#lang r7rs + +(define-library (pacman-project coin) + (import (scheme base) + (pp1 graphics) + (pacman-project screen) + (pacman-project maze)) + + (export draw-coins! + remove-coin!) + + (begin + + (define coin-size-offset 20) + + (define coins-layer (make-new-layer!)) + (define coin-tile (make-tile screen-width screen-height)) + ((coins-layer 'add-drawable!) coin-tile) + + ;tekent de muntjes + (define (draw-coins!) + (do ((row 0 (+ row 1))) + ((= row maze-rows)) + (do ((col 0 (+ col 1))) + ((= col maze-cols)) + (when (cell-coin? row col) + ((coin-tile 'draw-rectangle!) + (+ (* col cell-size) 7) + (+ (* row cell-size) maze-offset-y 7) + (- cell-size coin-size-offset) + (- cell-size coin-size-offset) + "yellow"))))) + + (draw-coins!) + + ;muntjes verwijderen + (define (remove-coin! row col) + ((coin-tile 'clear!)) ;alle coins verwijderen en alleen de coins die niet verwijderdt zijn tekenen + (draw-coins!)))) diff --git a/pacman-project/game-logic.rkt b/pacman-project/game-logic.rkt new file mode 100644 index 0000000..59a7579 --- /dev/null +++ b/pacman-project/game-logic.rkt @@ -0,0 +1,70 @@ +#lang r7rs + +; Game-logic ; + + +(define-library (pacman-project game-logic) + (import (scheme base) + (pacman-project maze) + (pacman-project pacman) + (pacman-project coin) + (pacman-project key) + (pacman-project score) + (pacman-project time-limit)) + + (export move-pacman!) + + (begin + + (define key-taken? #f) + + ;muntje opeten + (define (eat-coin! row col) + (cell-set! row col 2) + (remove-coin! row col)) + + ;sleutel oppakem + (define (take-key! row col) + (cell-set! row col 2) + (set! key-taken? #t) + (remove-key!)) + + ;beweegt pacman en checkt voor muren, muntjes, sleutels etc. + (define (move-pacman! x y) + (when (not (time-up?)) + (let* ((cur-x (pacman-x)) + (cur-y (pacman-y)) + (next-x (+ cur-x x)) + (next-y (+ cur-y y)) + (grid-col (quotient next-x cell-size)) + (grid-row (quotient (- next-y maze-offset-y) cell-size))) + + (cond + ;van links naar rechts + ((< grid-col 0) + (set-pacman-x! (* (- maze-cols 1) cell-size)) + (set-pacman-y! next-y)) + + ;van rechts naar links + ((>= grid-col maze-cols) + (set-pacman-x! 0) + (set-pacman-y! next-y)) + + ;als het een deur is openen we de deur + ((cell-door? grid-row grid-col) + (when key-taken? + (remove-door! grid-row grid-col))) + + ;normale beweging + (else + (when (not (cell-wall? grid-row grid-col)) + (set-pacman-x! next-x) + (set-pacman-y! next-y) + ;om te zien wat er op de volgende pos staat + (cond + ((cell-key? grid-row grid-col) + (take-key! grid-row grid-col)) + ((cell-coin? grid-row grid-col) + (eat-coin! grid-row grid-col) + (update-time-limit!) + (update-score!))))))))))) diff --git a/pacman-project/game.rkt b/pacman-project/game.rkt new file mode 100644 index 0000000..0ce546b --- /dev/null +++ b/pacman-project/game.rkt @@ -0,0 +1,19 @@ +#lang r7rs + +; Game ; + +(define-library (pacman-project game) + (import (scheme base) + (pacman-project score) + (pacman-project time-limit) + (pacman-project keyboard-handler) + (pacman-project main-loop) + (pacman-project test)) + + (begin + ;om het spel op te starten + (start-main-loop!) + (start-keyboard-handler!) + (draw-score!) + (draw-time-limit!))) + \ No newline at end of file diff --git a/pacman-project/game.rkt~ b/pacman-project/game.rkt~ new file mode 100644 index 0000000..0ce546b --- /dev/null +++ b/pacman-project/game.rkt~ @@ -0,0 +1,19 @@ +#lang r7rs + +; Game ; + +(define-library (pacman-project game) + (import (scheme base) + (pacman-project score) + (pacman-project time-limit) + (pacman-project keyboard-handler) + (pacman-project main-loop) + (pacman-project test)) + + (begin + ;om het spel op te starten + (start-main-loop!) + (start-keyboard-handler!) + (draw-score!) + (draw-time-limit!))) + \ No newline at end of file diff --git a/pacman-project/key.rkt b/pacman-project/key.rkt new file mode 100644 index 0000000..d03fe77 --- /dev/null +++ b/pacman-project/key.rkt @@ -0,0 +1,60 @@ +#lang r7rs + +(#%require (only racket/base random)) + + +; Key ADT ; + +(define-library (pacman-project key) + (import (scheme base) + (pp1 graphics) + (pacman-project screen) + (pacman-project maze) + (pacman-project coin)) + + (export draw-key! + remove-key!) + + (begin + + (define key-layer (make-new-layer!)) + + ;bitmap voor de sleutel + (define key (make-bitmap-tile "pacman-sprites/key.png")) + ((key 'set-scale!) 1.5) + ((key-layer 'add-drawable!) key) + + ;sleutel naast de score tekenen + (define taken-key (make-bitmap-tile "pacman-sprites/key.png")) + ((taken-key 'set-scale!) 3) + ((taken-key 'set-x!) 20) + ((taken-key 'set-y!) 35) + + + + ;de sleutel op een random positie in het doolhof plaatsen + (define (place-key-at-random-position!) + (let loop ((attempts 0)) ;attempts is het aantal keer dat er een key geplaats wordt. + ;dit wordt gedaan zodat er geen herhaling is bij het plaatsen van keys + (if (>= attempts 1000) + (error "valid position not found") ; + (let ((col (random 0 maze-cols)) + (row (random 0 maze-rows))) + (if (cell-coin? row col) ;als de cell een valid cell is (dus de plek waar een coin kan komen) + (begin + ((key 'set-x!) (* cell-size col)) + ((key 'set-y!) (+ (* row cell-size) maze-offset-y)) + (cell-set! row col 3) + (remove-coin! row col)) + (loop (+ attempts 1))))))) + + ;sleutel tekenen + (define (draw-key!) + (place-key-at-random-position!)) + + (draw-key!) + + ;sleutel verwijderen en aanduiden dat de sleutel gepakt werd + (define (remove-key!) + ((key-layer 'remove-drawable!) key) + ((key-layer 'add-drawable!) taken-key)))) diff --git a/pacman-project/keyboard-handler.rkt b/pacman-project/keyboard-handler.rkt new file mode 100644 index 0000000..6037e12 --- /dev/null +++ b/pacman-project/keyboard-handler.rkt @@ -0,0 +1,52 @@ +#lang r7rs + +; Keyboard-handler ; + + +(define-library (pacman-project keyboard-handler) + (import (scheme base) + (scheme write) + (pacman-project screen) + (pacman-project maze) + (pacman-project pacman) + (pacman-project game-logic) + (pacman-project pause-menu) + (pacman-project main-loop)) + + (export start-keyboard-handler!) + + (begin + + ;toetsen te beheren + (define (handle-keyboard! state key) + (when (eq? state 'pressed) + (cond + ((eq? key 'escape) + (if (not (paused?)) + (begin + (set-paused! #t) + (stop-main-loop!) + (draw-pause-menu!)) + (begin + (remove-pause-menu!) + (set-paused! #f) + (start-main-loop!)))) + ((not (paused?)) + (let ((cell cell-size)) + (cond + ((eq? key 'right) + (move-pacman! cell 0) + (rotate-pacman! 'right)) + ((eq? key 'left) + (move-pacman! (- cell) 0) + (rotate-pacman! 'left)) + ((eq? key 'up) + (move-pacman! 0 (- cell)) + (rotate-pacman! 'up)) + ((eq? key 'down) + (move-pacman! 0 cell) + (rotate-pacman! 'down)))))))) + + ;zodat de keyboard geconnecteert is met het spelscherm + (define (start-keyboard-handler!) + ((screen 'set-key-callback!) handle-keyboard!)))) diff --git a/pacman-project/main-loop.rkt b/pacman-project/main-loop.rkt new file mode 100644 index 0000000..448e5c2 --- /dev/null +++ b/pacman-project/main-loop.rkt @@ -0,0 +1,30 @@ +#lang r7rs + +; Main loop ADT ; + +(define-library (pacman-project main-loop) + (import (scheme base) + (pacman-project screen) + (pacman-project pacman) + (pacman-project time-limit)) + + (export start-main-loop! + stop-main-loop!) + + (begin + + ;stopt de game-loop + (define (stop-main-loop!) + ((screen 'set-update-callback!) + (lambda (ms) (values)))) + + ;start de game-loop + (define (start-main-loop!) + ((screen 'set-update-callback!) + (lambda (ms) + (cond + ((time-up?) ;wanneer de tijd om is stopt het spel + (stop-main-loop!)) + (else + (animate-pacman! ms) + (decrease-time-limit! ms)))))))) diff --git a/pacman-project/maze.rkt b/pacman-project/maze.rkt new file mode 100644 index 0000000..7399f9d --- /dev/null +++ b/pacman-project/maze.rkt @@ -0,0 +1,128 @@ +#lang r7rs + +; Maze ADT ; + + +(define-library (pacman-project maze) + (import (scheme base) + (pp1 graphics) + (pacman-project screen)) + + (export maze-rows + maze-cols + cell-size + maze-offset-y + cell-ref + cell-set! + cell-wall? + cell-coin? + cell-empty? + cell-key? + cell-door? + draw-maze! + remove-door!) + + (begin + + ;conmstanten + (define cell-size 24) + (define maze-offset-y 97) ;offsets om de maze mooi te kunnen plaatsen + (define maze-size-offset 6) + + ;we maken een maze aan van 31 rijen x 28 kolommen + ;vector ipv #() omda vector mutable is en #() ni. + + ;0 = muntje + ;1 = muur + ;2 = leeg + ;3 = sleutel + ;4 = deur + (define maze + (vector (vector 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1) + (vector 1 0 0 0 0 0 0 0 0 0 0 0 0 1 1 0 0 0 0 0 0 0 0 0 0 0 0 1) + (vector 1 0 1 1 1 1 0 1 1 1 1 1 0 1 1 0 1 1 1 1 1 0 1 1 1 1 0 1) + (vector 1 0 1 0 0 1 0 1 1 1 1 1 0 1 1 0 1 1 1 1 1 0 1 1 1 1 0 1) + (vector 1 0 1 4 1 1 0 1 1 1 1 1 0 1 1 0 1 1 1 1 1 0 1 1 1 1 0 1) + (vector 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1) + (vector 1 0 1 1 1 1 0 1 1 0 1 1 1 1 1 1 1 1 0 1 1 0 1 1 1 1 0 1) + (vector 1 0 1 1 1 1 0 1 1 0 1 1 1 1 1 1 1 1 0 1 1 0 1 1 1 1 0 1) + (vector 1 0 0 0 0 0 0 1 1 0 0 0 0 1 1 0 0 0 0 1 1 0 0 0 0 0 0 1) + (vector 1 1 1 1 1 1 0 1 1 1 1 1 0 1 1 0 1 1 1 1 1 0 1 1 1 1 1 1) + (vector 2 2 2 2 2 1 0 1 1 1 1 1 0 1 1 0 1 1 1 1 1 0 1 2 2 2 2 2) + (vector 2 2 2 2 2 1 0 1 1 0 0 0 0 0 0 0 0 0 0 1 1 0 1 2 2 2 2 2) + (vector 2 2 2 2 2 1 0 1 1 0 1 1 1 4 4 1 1 1 0 1 1 0 1 2 2 2 2 2) + (vector 1 1 1 1 1 1 0 1 1 0 1 2 2 2 2 2 2 1 0 1 1 0 1 1 1 1 1 1) + (vector 2 0 0 0 0 0 0 0 0 0 1 2 2 2 2 2 2 1 0 0 0 0 0 0 0 0 0 2) + (vector 1 1 1 1 1 1 0 1 1 0 1 2 2 2 2 2 2 1 0 1 1 0 1 1 1 1 1 1) + (vector 2 2 2 2 2 1 0 1 1 0 1 1 1 1 1 1 1 1 0 1 1 0 1 2 2 2 2 2) + (vector 2 2 2 2 2 1 0 1 1 0 0 0 0 0 0 0 0 0 0 1 1 0 1 2 2 2 2 2) + (vector 2 2 2 2 2 1 0 1 1 0 1 1 1 1 1 1 1 1 0 1 1 0 1 2 2 2 2 2) + (vector 1 1 1 1 1 1 0 1 1 0 1 1 1 1 1 1 1 1 0 1 1 0 1 1 1 1 1 1) + (vector 1 0 0 0 0 0 0 0 0 0 0 0 0 1 1 0 0 0 0 0 0 0 0 0 0 0 0 1) + (vector 1 0 1 1 1 1 0 1 1 1 1 1 0 1 1 0 1 1 1 1 1 0 1 1 1 1 0 1) + (vector 1 0 1 1 1 1 0 1 1 1 1 1 0 1 1 0 1 1 1 1 1 0 1 1 1 1 0 1) + (vector 1 0 0 0 1 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 0 0 0 1) + (vector 1 1 1 0 1 1 0 1 1 0 1 1 1 1 1 1 1 1 0 1 1 0 1 1 0 1 1 1) + (vector 1 1 1 0 1 1 0 1 1 0 1 1 1 1 1 1 1 1 0 1 1 0 1 1 0 1 1 1) + (vector 1 0 0 0 0 0 0 1 1 0 0 0 0 1 1 0 0 0 0 4 1 0 0 0 0 0 0 1) + (vector 1 0 1 1 1 1 1 1 1 1 1 1 0 1 1 0 1 1 1 0 0 1 1 1 1 1 0 1) + (vector 1 0 1 1 1 1 1 1 1 1 1 1 0 1 1 0 1 1 1 1 1 1 1 1 1 1 0 1) + (vector 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1) + (vector 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1))) + + (define maze-rows (vector-length maze)) + (define maze-cols (vector-length (vector-ref maze 0))) + + + ;geeft waarde terug v/e cell + (define (cell-ref row col) + (vector-ref (vector-ref maze row) col)) + + ;past waarde aan v/e cell + (define (cell-set! row col value) + (vector-set! (vector-ref maze row) col value)) + + (define (cell-wall? row col) + (= (cell-ref row col) 1)) + + (define (cell-coin? row col) + (= (cell-ref row col) 0)) + + (define (cell-empty? row col) + (= (cell-ref row col) 2)) + + (define (cell-key? row col) + (= (cell-ref row col) 3)) + + (define (cell-door? row col) + (= (cell-ref row col) 4)) + + + (define maze-layer (make-new-layer!)) + (define maze-tile (make-tile screen-width screen-height)) + ((maze-layer 'add-drawable!) maze-tile) + + ;tekent de maze + (define (draw-maze!) + (do ((row 0 (+ row 1))) + ((= row maze-rows)) + (do ((col 0 (+ col 1))) + ((= col maze-cols)) + (let ((cell (cell-ref row col))) + (cond + ((= cell 1) + ((maze-tile 'draw-rectangle!) (* col cell-size) (+ (* row cell-size) maze-offset-y) (- cell-size maze-size-offset) (- cell-size maze-size-offset) "blue")) + ((= cell 4) + ((maze-tile 'draw-rectangle!) (* col cell-size) (+ (* row cell-size) maze-offset-y) (- cell-size maze-size-offset) (- cell-size maze-size-offset) "pink"))))))) ;we tekenen hier ook de deuren aangezien ze deel uitmaken van de maze + + (draw-maze!) + + ;verwijdert een deur uit de maze + (define (remove-door! row col) + (cell-set! row col 2) + ((maze-tile 'draw-rectangle!) + (* col cell-size) + (+ (* row cell-size) maze-offset-y) + (- cell-size maze-size-offset) + (- cell-size maze-size-offset) + "black")))) diff --git a/pacman-project/pacman-sprites/.DS_Store b/pacman-project/pacman-sprites/.DS_Store new file mode 100644 index 0000000..2e4ac07 Binary files /dev/null and b/pacman-project/pacman-sprites/.DS_Store differ diff --git a/pacman-project/pacman-sprites/100-points.png b/pacman-project/pacman-sprites/100-points.png new file mode 100644 index 0000000..0cea470 Binary files /dev/null and b/pacman-project/pacman-sprites/100-points.png differ diff --git a/pacman-project/pacman-sprites/1600-points.png b/pacman-project/pacman-sprites/1600-points.png new file mode 100644 index 0000000..1163c73 Binary files /dev/null and b/pacman-project/pacman-sprites/1600-points.png differ diff --git a/pacman-project/pacman-sprites/200-points.png b/pacman-project/pacman-sprites/200-points.png new file mode 100644 index 0000000..bc1cd36 Binary files /dev/null and b/pacman-project/pacman-sprites/200-points.png differ diff --git a/pacman-project/pacman-sprites/300-points.png b/pacman-project/pacman-sprites/300-points.png new file mode 100644 index 0000000..dacd727 Binary files /dev/null and b/pacman-project/pacman-sprites/300-points.png differ diff --git a/pacman-project/pacman-sprites/400-points.png b/pacman-project/pacman-sprites/400-points.png new file mode 100644 index 0000000..2dbe550 Binary files /dev/null and b/pacman-project/pacman-sprites/400-points.png differ diff --git a/pacman-project/pacman-sprites/500-points.png b/pacman-project/pacman-sprites/500-points.png new file mode 100644 index 0000000..6356e83 Binary files /dev/null and b/pacman-project/pacman-sprites/500-points.png differ diff --git a/pacman-project/pacman-sprites/700-points.png b/pacman-project/pacman-sprites/700-points.png new file mode 100644 index 0000000..c99e932 Binary files /dev/null and b/pacman-project/pacman-sprites/700-points.png differ diff --git a/pacman-project/pacman-sprites/800-points.png b/pacman-project/pacman-sprites/800-points.png new file mode 100644 index 0000000..cd81dbe Binary files /dev/null and b/pacman-project/pacman-sprites/800-points.png differ diff --git a/pacman-project/pacman-sprites/Arcade - Pac-Man - Miscellaneous - All Assets_Palettes.png b/pacman-project/pacman-sprites/Arcade - Pac-Man - Miscellaneous - All Assets_Palettes.png new file mode 100644 index 0000000..22773b0 Binary files /dev/null and b/pacman-project/pacman-sprites/Arcade - Pac-Man - Miscellaneous - All Assets_Palettes.png differ diff --git a/pacman-project/pacman-sprites/Pac-Man General Sprites.png b/pacman-project/pacman-sprites/Pac-Man General Sprites.png new file mode 100644 index 0000000..cf01851 Binary files /dev/null and b/pacman-project/pacman-sprites/Pac-Man General Sprites.png differ diff --git a/pacman-project/pacman-sprites/apple.png b/pacman-project/pacman-sprites/apple.png new file mode 100644 index 0000000..b7afa61 Binary files /dev/null and b/pacman-project/pacman-sprites/apple.png differ diff --git a/pacman-project/pacman-sprites/bell.png b/pacman-project/pacman-sprites/bell.png new file mode 100644 index 0000000..c8bf9e4 Binary files /dev/null and b/pacman-project/pacman-sprites/bell.png differ diff --git a/pacman-project/pacman-sprites/blinky-down-1.png b/pacman-project/pacman-sprites/blinky-down-1.png new file mode 100644 index 0000000..d3a7d25 Binary files /dev/null and b/pacman-project/pacman-sprites/blinky-down-1.png differ diff --git a/pacman-project/pacman-sprites/blinky-down-2.png b/pacman-project/pacman-sprites/blinky-down-2.png new file mode 100644 index 0000000..c4ac85d Binary files /dev/null and b/pacman-project/pacman-sprites/blinky-down-2.png differ diff --git a/pacman-project/pacman-sprites/blinky-left-1.png b/pacman-project/pacman-sprites/blinky-left-1.png new file mode 100644 index 0000000..b94f45a Binary files /dev/null and b/pacman-project/pacman-sprites/blinky-left-1.png differ diff --git a/pacman-project/pacman-sprites/blinky-left-2.png b/pacman-project/pacman-sprites/blinky-left-2.png new file mode 100644 index 0000000..65742f9 Binary files /dev/null and b/pacman-project/pacman-sprites/blinky-left-2.png differ diff --git a/pacman-project/pacman-sprites/blinky-right-1.png b/pacman-project/pacman-sprites/blinky-right-1.png new file mode 100644 index 0000000..a4f8135 Binary files /dev/null and b/pacman-project/pacman-sprites/blinky-right-1.png differ diff --git a/pacman-project/pacman-sprites/blinky-right-2.png b/pacman-project/pacman-sprites/blinky-right-2.png new file mode 100644 index 0000000..85c3a65 Binary files /dev/null and b/pacman-project/pacman-sprites/blinky-right-2.png differ diff --git a/pacman-project/pacman-sprites/blinky-up-1.png b/pacman-project/pacman-sprites/blinky-up-1.png new file mode 100644 index 0000000..a653b98 Binary files /dev/null and b/pacman-project/pacman-sprites/blinky-up-1.png differ diff --git a/pacman-project/pacman-sprites/blinky-up-2.png b/pacman-project/pacman-sprites/blinky-up-2.png new file mode 100644 index 0000000..e515386 Binary files /dev/null and b/pacman-project/pacman-sprites/blinky-up-2.png differ diff --git a/pacman-project/pacman-sprites/cherry.png b/pacman-project/pacman-sprites/cherry.png new file mode 100644 index 0000000..93cc7e9 Binary files /dev/null and b/pacman-project/pacman-sprites/cherry.png differ diff --git a/pacman-project/pacman-sprites/clyde-down-1.png b/pacman-project/pacman-sprites/clyde-down-1.png new file mode 100644 index 0000000..4cb3670 Binary files /dev/null and b/pacman-project/pacman-sprites/clyde-down-1.png differ diff --git a/pacman-project/pacman-sprites/clyde-down-2.png b/pacman-project/pacman-sprites/clyde-down-2.png new file mode 100644 index 0000000..5a2a476 Binary files /dev/null and b/pacman-project/pacman-sprites/clyde-down-2.png differ diff --git a/pacman-project/pacman-sprites/clyde-left-1.png b/pacman-project/pacman-sprites/clyde-left-1.png new file mode 100644 index 0000000..44144c2 Binary files /dev/null and b/pacman-project/pacman-sprites/clyde-left-1.png differ diff --git a/pacman-project/pacman-sprites/clyde-left-2.png b/pacman-project/pacman-sprites/clyde-left-2.png new file mode 100644 index 0000000..f073827 Binary files /dev/null and b/pacman-project/pacman-sprites/clyde-left-2.png differ diff --git a/pacman-project/pacman-sprites/clyde-right-1.png b/pacman-project/pacman-sprites/clyde-right-1.png new file mode 100644 index 0000000..d6a5af8 Binary files /dev/null and b/pacman-project/pacman-sprites/clyde-right-1.png differ diff --git a/pacman-project/pacman-sprites/clyde-right-2.png b/pacman-project/pacman-sprites/clyde-right-2.png new file mode 100644 index 0000000..4e41a45 Binary files /dev/null and b/pacman-project/pacman-sprites/clyde-right-2.png differ diff --git a/pacman-project/pacman-sprites/clyde-up-1.png b/pacman-project/pacman-sprites/clyde-up-1.png new file mode 100644 index 0000000..ea0d1fc Binary files /dev/null and b/pacman-project/pacman-sprites/clyde-up-1.png differ diff --git a/pacman-project/pacman-sprites/clyde-up-2.png b/pacman-project/pacman-sprites/clyde-up-2.png new file mode 100644 index 0000000..10fcebb Binary files /dev/null and b/pacman-project/pacman-sprites/clyde-up-2.png differ diff --git a/pacman-project/pacman-sprites/flower.png b/pacman-project/pacman-sprites/flower.png new file mode 100644 index 0000000..83d6ada Binary files /dev/null and b/pacman-project/pacman-sprites/flower.png differ diff --git a/pacman-project/pacman-sprites/ghost-eyes-down.png b/pacman-project/pacman-sprites/ghost-eyes-down.png new file mode 100644 index 0000000..6c96fa4 Binary files /dev/null and b/pacman-project/pacman-sprites/ghost-eyes-down.png differ diff --git a/pacman-project/pacman-sprites/ghost-eyes-left.png b/pacman-project/pacman-sprites/ghost-eyes-left.png new file mode 100644 index 0000000..3b48774 Binary files /dev/null and b/pacman-project/pacman-sprites/ghost-eyes-left.png differ diff --git a/pacman-project/pacman-sprites/ghost-eyes-right.png b/pacman-project/pacman-sprites/ghost-eyes-right.png new file mode 100644 index 0000000..c5060f1 Binary files /dev/null and b/pacman-project/pacman-sprites/ghost-eyes-right.png differ diff --git a/pacman-project/pacman-sprites/ghost-eyes-up.png b/pacman-project/pacman-sprites/ghost-eyes-up.png new file mode 100644 index 0000000..a1b7352 Binary files /dev/null and b/pacman-project/pacman-sprites/ghost-eyes-up.png differ diff --git a/pacman-project/pacman-sprites/inky-down-1.png b/pacman-project/pacman-sprites/inky-down-1.png new file mode 100644 index 0000000..98b37d7 Binary files /dev/null and b/pacman-project/pacman-sprites/inky-down-1.png differ diff --git a/pacman-project/pacman-sprites/inky-down-2.png b/pacman-project/pacman-sprites/inky-down-2.png new file mode 100644 index 0000000..6843175 Binary files /dev/null and b/pacman-project/pacman-sprites/inky-down-2.png differ diff --git a/pacman-project/pacman-sprites/inky-left-1.png b/pacman-project/pacman-sprites/inky-left-1.png new file mode 100644 index 0000000..b010a41 Binary files /dev/null and b/pacman-project/pacman-sprites/inky-left-1.png differ diff --git a/pacman-project/pacman-sprites/inky-left-2.png b/pacman-project/pacman-sprites/inky-left-2.png new file mode 100644 index 0000000..6641ff5 Binary files /dev/null and b/pacman-project/pacman-sprites/inky-left-2.png differ diff --git a/pacman-project/pacman-sprites/inky-right-1.png b/pacman-project/pacman-sprites/inky-right-1.png new file mode 100644 index 0000000..e59def5 Binary files /dev/null and b/pacman-project/pacman-sprites/inky-right-1.png differ diff --git a/pacman-project/pacman-sprites/inky-right-2.png b/pacman-project/pacman-sprites/inky-right-2.png new file mode 100644 index 0000000..b942cdb Binary files /dev/null and b/pacman-project/pacman-sprites/inky-right-2.png differ diff --git a/pacman-project/pacman-sprites/inky-up-1.png b/pacman-project/pacman-sprites/inky-up-1.png new file mode 100644 index 0000000..3645c4c Binary files /dev/null and b/pacman-project/pacman-sprites/inky-up-1.png differ diff --git a/pacman-project/pacman-sprites/inky-up-2.png b/pacman-project/pacman-sprites/inky-up-2.png new file mode 100644 index 0000000..4c3a4ae Binary files /dev/null and b/pacman-project/pacman-sprites/inky-up-2.png differ diff --git a/pacman-project/pacman-sprites/key.png b/pacman-project/pacman-sprites/key.png new file mode 100644 index 0000000..215cfac Binary files /dev/null and b/pacman-project/pacman-sprites/key.png differ diff --git a/pacman-project/pacman-sprites/melon.png b/pacman-project/pacman-sprites/melon.png new file mode 100644 index 0000000..212ee46 Binary files /dev/null and b/pacman-project/pacman-sprites/melon.png differ diff --git a/pacman-project/pacman-sprites/orange.png b/pacman-project/pacman-sprites/orange.png new file mode 100644 index 0000000..a511ac7 Binary files /dev/null and b/pacman-project/pacman-sprites/orange.png differ diff --git a/pacman-project/pacman-sprites/pacman-closed.png b/pacman-project/pacman-sprites/pacman-closed.png new file mode 100644 index 0000000..2c48bb1 Binary files /dev/null and b/pacman-project/pacman-sprites/pacman-closed.png differ diff --git a/pacman-project/pacman-sprites/pacman-death-1.png b/pacman-project/pacman-sprites/pacman-death-1.png new file mode 100644 index 0000000..15645d3 Binary files /dev/null and b/pacman-project/pacman-sprites/pacman-death-1.png differ diff --git a/pacman-project/pacman-sprites/pacman-death-10.png b/pacman-project/pacman-sprites/pacman-death-10.png new file mode 100644 index 0000000..c2fbaed Binary files /dev/null and b/pacman-project/pacman-sprites/pacman-death-10.png differ diff --git a/pacman-project/pacman-sprites/pacman-death-11.png b/pacman-project/pacman-sprites/pacman-death-11.png new file mode 100644 index 0000000..c6abefa Binary files /dev/null and b/pacman-project/pacman-sprites/pacman-death-11.png differ diff --git a/pacman-project/pacman-sprites/pacman-death-12.png b/pacman-project/pacman-sprites/pacman-death-12.png new file mode 100644 index 0000000..939fc6f Binary files /dev/null and b/pacman-project/pacman-sprites/pacman-death-12.png differ diff --git a/pacman-project/pacman-sprites/pacman-death-13.png b/pacman-project/pacman-sprites/pacman-death-13.png new file mode 100644 index 0000000..f91e01f Binary files /dev/null and b/pacman-project/pacman-sprites/pacman-death-13.png differ diff --git a/pacman-project/pacman-sprites/pacman-death-2.png b/pacman-project/pacman-sprites/pacman-death-2.png new file mode 100644 index 0000000..eff017c Binary files /dev/null and b/pacman-project/pacman-sprites/pacman-death-2.png differ diff --git a/pacman-project/pacman-sprites/pacman-death-3.png b/pacman-project/pacman-sprites/pacman-death-3.png new file mode 100644 index 0000000..6ebe5c6 Binary files /dev/null and b/pacman-project/pacman-sprites/pacman-death-3.png differ diff --git a/pacman-project/pacman-sprites/pacman-death-4.png b/pacman-project/pacman-sprites/pacman-death-4.png new file mode 100644 index 0000000..09157bd Binary files /dev/null and b/pacman-project/pacman-sprites/pacman-death-4.png differ diff --git a/pacman-project/pacman-sprites/pacman-death-5.png b/pacman-project/pacman-sprites/pacman-death-5.png new file mode 100644 index 0000000..5458e32 Binary files /dev/null and b/pacman-project/pacman-sprites/pacman-death-5.png differ diff --git a/pacman-project/pacman-sprites/pacman-death-6.png b/pacman-project/pacman-sprites/pacman-death-6.png new file mode 100644 index 0000000..17a34d2 Binary files /dev/null and b/pacman-project/pacman-sprites/pacman-death-6.png differ diff --git a/pacman-project/pacman-sprites/pacman-death-7.png b/pacman-project/pacman-sprites/pacman-death-7.png new file mode 100644 index 0000000..03bac3c Binary files /dev/null and b/pacman-project/pacman-sprites/pacman-death-7.png differ diff --git a/pacman-project/pacman-sprites/pacman-death-8.png b/pacman-project/pacman-sprites/pacman-death-8.png new file mode 100644 index 0000000..1dbac6e Binary files /dev/null and b/pacman-project/pacman-sprites/pacman-death-8.png differ diff --git a/pacman-project/pacman-sprites/pacman-death-9.png b/pacman-project/pacman-sprites/pacman-death-9.png new file mode 100644 index 0000000..abbdc24 Binary files /dev/null and b/pacman-project/pacman-sprites/pacman-death-9.png differ diff --git a/pacman-project/pacman-sprites/pacman-open.png b/pacman-project/pacman-sprites/pacman-open.png new file mode 100644 index 0000000..1d7d2c3 Binary files /dev/null and b/pacman-project/pacman-sprites/pacman-open.png differ diff --git a/pacman-project/pacman-sprites/pinky-down-1.png b/pacman-project/pacman-sprites/pinky-down-1.png new file mode 100644 index 0000000..9783321 Binary files /dev/null and b/pacman-project/pacman-sprites/pinky-down-1.png differ diff --git a/pacman-project/pacman-sprites/pinky-down-2.png b/pacman-project/pacman-sprites/pinky-down-2.png new file mode 100644 index 0000000..301703a Binary files /dev/null and b/pacman-project/pacman-sprites/pinky-down-2.png differ diff --git a/pacman-project/pacman-sprites/pinky-left-1.png b/pacman-project/pacman-sprites/pinky-left-1.png new file mode 100644 index 0000000..cce34ad Binary files /dev/null and b/pacman-project/pacman-sprites/pinky-left-1.png differ diff --git a/pacman-project/pacman-sprites/pinky-left-2.png b/pacman-project/pacman-sprites/pinky-left-2.png new file mode 100644 index 0000000..897d689 Binary files /dev/null and b/pacman-project/pacman-sprites/pinky-left-2.png differ diff --git a/pacman-project/pacman-sprites/pinky-right-1.png b/pacman-project/pacman-sprites/pinky-right-1.png new file mode 100644 index 0000000..b1a4af8 Binary files /dev/null and b/pacman-project/pacman-sprites/pinky-right-1.png differ diff --git a/pacman-project/pacman-sprites/pinky-right-2.png b/pacman-project/pacman-sprites/pinky-right-2.png new file mode 100644 index 0000000..677e491 Binary files /dev/null and b/pacman-project/pacman-sprites/pinky-right-2.png differ diff --git a/pacman-project/pacman-sprites/pinky-up-1.png b/pacman-project/pacman-sprites/pinky-up-1.png new file mode 100644 index 0000000..bbee0a9 Binary files /dev/null and b/pacman-project/pacman-sprites/pinky-up-1.png differ diff --git a/pacman-project/pacman-sprites/pinky-up-2.png b/pacman-project/pacman-sprites/pinky-up-2.png new file mode 100644 index 0000000..7c16b08 Binary files /dev/null and b/pacman-project/pacman-sprites/pinky-up-2.png differ diff --git a/pacman-project/pacman-sprites/scared-ghost-blue-1.png b/pacman-project/pacman-sprites/scared-ghost-blue-1.png new file mode 100644 index 0000000..0bb4ec2 Binary files /dev/null and b/pacman-project/pacman-sprites/scared-ghost-blue-1.png differ diff --git a/pacman-project/pacman-sprites/scared-ghost-blue-2.png b/pacman-project/pacman-sprites/scared-ghost-blue-2.png new file mode 100644 index 0000000..2742a99 Binary files /dev/null and b/pacman-project/pacman-sprites/scared-ghost-blue-2.png differ diff --git a/pacman-project/pacman-sprites/scared-ghost-white-2.png b/pacman-project/pacman-sprites/scared-ghost-white-2.png new file mode 100644 index 0000000..a7d132c Binary files /dev/null and b/pacman-project/pacman-sprites/scared-ghost-white-2.png differ diff --git a/pacman-project/pacman-sprites/scared-ghost-white=1.png b/pacman-project/pacman-sprites/scared-ghost-white=1.png new file mode 100644 index 0000000..7fb6808 Binary files /dev/null and b/pacman-project/pacman-sprites/scared-ghost-white=1.png differ diff --git a/pacman-project/pacman-sprites/strawberry.png b/pacman-project/pacman-sprites/strawberry.png new file mode 100644 index 0000000..7e20378 Binary files /dev/null and b/pacman-project/pacman-sprites/strawberry.png differ diff --git a/pacman-project/pacman.rkt b/pacman-project/pacman.rkt new file mode 100644 index 0000000..a449321 --- /dev/null +++ b/pacman-project/pacman.rkt @@ -0,0 +1,69 @@ +#lang r7rs + +; Pacman ADT ; + + +(define-library (pacman-project pacman) + (import (scheme base) + (pp1 graphics) + (pacman-project screen) + (pacman-project maze)) + + (export pacman-x + pacman-y + set-pacman-x! + set-pacman-y! + animate-pacman! + rotate-pacman!) + + (begin + + (define time-since-last-animation 0) + (define animation-interval 100) + + (define pacman-layer (make-new-layer!)) + + ;bitmap-sequence voor pacman + (define pacman-bitmap-tiles + (list (make-bitmap-tile "pacman-sprites/pacman-death-1.png") + (make-bitmap-tile "pacman-sprites/pacman-closed.png") + (make-bitmap-tile "pacman-sprites/pacman-open.png"))) + + (define pacman-sprite (make-tile-sequence pacman-bitmap-tiles)) + ((pacman-sprite 'set-scale!) 1.5) + ((pacman-layer 'add-drawable!) pacman-sprite) + + ;start-positie van pacman + ((pacman-sprite 'set-x!) (* 2 cell-size)) + ((pacman-sprite 'set-y!) (+ (* 5 cell-size) maze-offset-y)) + + + ;geeft x-waarde terug + (define (pacman-x) + ((pacman-sprite 'get-x))) + + ;geeft y-waarde terug + (define (pacman-y) + ((pacman-sprite 'get-y))) + + ;past de x-waarde aan + (define (set-pacman-x! x) + ((pacman-sprite 'set-x!) x)) + + ;past de y-waarde aan + (define (set-pacman-y! y) + ((pacman-sprite 'set-y!) y)) + + ;pacman roteren obv zijn direction + (define (rotate-pacman! direction) + (cond ((eq? direction 'right) ((pacman-sprite 'rotate!) 0)) + ((eq? direction 'left) ((pacman-sprite 'rotate!) 180)) + ((eq? direction 'up) ((pacman-sprite 'rotate!) 90)) + ((eq? direction 'down) ((pacman-sprite 'rotate!) -90)))) + + ;pacman animaten door langs de bitmap sequence te gaan + (define (animate-pacman! ms) + (set! time-since-last-animation (+ time-since-last-animation ms)) + (when (>= time-since-last-animation animation-interval) + ((pacman-sprite 'set-next!)) + (set! time-since-last-animation 0))))) diff --git a/pacman-project/pause-menu.rkt b/pacman-project/pause-menu.rkt new file mode 100644 index 0000000..5579fb8 --- /dev/null +++ b/pacman-project/pause-menu.rkt @@ -0,0 +1,39 @@ +#lang r7rs + +; Pause-menu ADT ; + + +(define-library (pacman-project pause-menu) + (import (scheme base) + (pp1 graphics) + (pacman-project screen)) + + (export paused? + set-paused! + draw-pause-menu! + remove-pause-menu!) + + (begin + + (define pause-status #f) + + (define pause-layer (make-new-layer!)) + + ;checken of we gepauzeerd zijn + (define (paused?) + pause-status) + + ;om de pauze status aan te passen + (define (set-paused! status) + (set! pause-status status)) + + ;pauzescherm tekenen + (define (draw-pause-menu!) + (let ((pause-tile (make-tile screen-width screen-height))) + ((pause-layer 'add-drawable!) pause-tile) + ((pause-tile 'draw-rectangle!) 0 90 670 screen-height "black") + ((pause-tile 'draw-text!) "Game Paused" 40 200 400 "red"))) + + ;pauzescherm verwijderen + (define (remove-pause-menu!) + ((pause-layer 'empty!))))) diff --git a/pacman-project/pp1.zip b/pacman-project/pp1.zip new file mode 100644 index 0000000..528a4a1 Binary files /dev/null and b/pacman-project/pp1.zip differ diff --git a/pacman-project/score.rkt b/pacman-project/score.rkt new file mode 100644 index 0000000..944d17e --- /dev/null +++ b/pacman-project/score.rkt @@ -0,0 +1,36 @@ +#lang r7rs + +; Score ADT ; + + +(define-library (pacman-project score) + (import (scheme base) + (pp1 graphics) + (pacman-project screen)) + + (export draw-score! + update-score! + get-score) + + (begin + + (define score 0) + + (define score-layer (make-new-layer!)) + (define score-tile (make-tile screen-width screen-height)) + ((score-layer 'add-drawable!) score-tile) + + ;de current score teruggeven + (define (get-score) + score) + + ;score op het scherm tekenen + (define (draw-score!) + ((score-tile 'draw-text!) + (number->string score) 40 560 20 "white")) + + ;wanneer een muntje gegeten wordt wordt de score met 10 verhoogt + (define (update-score!) + (set! score (+ score 10)) + ((score-tile 'clear!)) + (draw-score!)))) diff --git a/pacman-project/screen.rkt b/pacman-project/screen.rkt new file mode 100644 index 0000000..029d765 --- /dev/null +++ b/pacman-project/screen.rkt @@ -0,0 +1,26 @@ +#lang r7rs + +; Screen ADT ; + +(define-library (pacman-project screen) + (import (scheme base) + (pp1 graphics)) + + (export screen + screen-width + screen-height + make-new-layer!) + + (begin + + ;constanten + (define screen-width 1000) + (define screen-height 830) + + ;scherm aanmaken + (define screen (make-window screen-width screen-height "Pacman")) + ((screen 'set-background!) "black") + + ;nieuwe layer op her scherm maken + (define (make-new-layer!) + ((screen 'new-layer!))))) diff --git a/pacman-project/test.rkt b/pacman-project/test.rkt new file mode 100644 index 0000000..fa76c73 --- /dev/null +++ b/pacman-project/test.rkt @@ -0,0 +1,60 @@ +#lang r7rs + +;;; Tests voor de spelinteracties van het Pac-Man project. + +(define-library (pacman-project tests) + (import (scheme base) + (scheme write) + (pp1 graphics) + (pacman-project screen) + (pacman-project maze) + (pacman-project coin) + (pacman-project key) + (pacman-project pacman) + (pacman-project score) + (pacman-project time-limit) + (pacman-project pause-menu) + (pacman-project game-logic)) + + (begin + + ;test of pacman door de muur kan of niet + (set-pacman-x! (* 1 cell-size)) + (set-pacman-y! (+ (* 1 cell-size) maze-offset-y)) + (display "Pac-Man kan niet door de muur: ") + (display (= (pacman-x) (begin (move-pacman! (- cell-size) 0) (pacman-x)))) + (newline) + + ;test of pacman een muntje opeet + (set-pacman-x! (* 4 cell-size)) + (set-pacman-y! (+ (* 5 cell-size) maze-offset-y)) + (move-pacman! cell-size 0) + (display "Muntje wordt opgegeten: ") + (display (cell-empty? 5 5)) + (newline) + (cell-set! 5 5 0) + (remove-coin! 5 5) + + ;test of de score verhoogd wordt of niet + (display "Score is verhoogd: ") + (display (>= (get-score) 10)) + (newline) + + ;check of de teleportatie werkt + (set-pacman-x! (* 0 cell-size)) + (set-pacman-y! (+ (* 14 cell-size) maze-offset-y)) + (move-pacman! (- cell-size) 0) + (display "Teleportatie links naar rechts: ") + (display (= (pacman-x) (* (- maze-cols 1) cell-size))) + (newline) + + ;test of een deur pas open gaat als de sleutel opgepakt werd. + (set-pacman-x! (* 2 cell-size)) + (set-pacman-y! (+ (* 4 cell-size) maze-offset-y)) + (let ((x-voor (pacman-x))) + (move-pacman! cell-size 0) + (display "Deur blokkeert zonder sleutel: ") + (display (= (pacman-x) x-voor)) + (newline) + (set-pacman-x! (* 2 cell-size)) + (set-pacman-y! (+ (* 5 cell-size) maze-offset-y))))) \ No newline at end of file diff --git a/pacman-project/time-limit.rkt b/pacman-project/time-limit.rkt new file mode 100644 index 0000000..deb1216 --- /dev/null +++ b/pacman-project/time-limit.rkt @@ -0,0 +1,63 @@ +#lang r7rs + +; Time limit ADT ; + + +(define-library (pacman-project time-limit) + (import (scheme base) + (pp1 graphics) + (pacman-project screen)) + + (export draw-time-limit! + decrease-time-limit! + update-time-limit! + time-up?) + + (begin + + (define time-remaining 60) ;1 min = 60 seconden + (define time-since-last-tick 0) + + (define time-layer (make-new-layer!)) + (define time-tile (make-tile screen-width screen-height)) + ((time-layer 'add-drawable!) time-tile) + + + + ;omn de tijdslimiet mooi op het scherm te kunnen krijgen + (define (format-time seconds) + (let* ((minutes (quotient seconds 60)) ;om het aantal minuten te krijgen + (seconds (remainder seconds 60)) ;om het aantal seconden te krijgen + (min-str (number->string minutes)) + (sec-str (number->string seconds))) + (string-append min-str + ":" + (if (< seconds 10) + (string-append "0" sec-str) ;om .. : 0.. te krijgen + sec-str)))) ;anders gwn tekenen + + ;teken de remaning time op het scherm + (define (draw-time-limit!) + ((time-tile 'draw-text!) "Time remaining:" 35 710 300 "white") + ((time-tile 'draw-rectangle!) 670 0 24 screen-height "white") + ((time-tile 'draw-text!) + (format-time time-remaining) 40 800 400 "white")) + + ;tijd verminderdt met 1 seconde + (define (decrease-time-limit! ms) + (set! time-since-last-tick (+ time-since-last-tick ms)) + (when (>= time-since-last-tick 1000) + (set! time-since-last-tick 0) + (when (> time-remaining 0) + (set! time-remaining (- time-remaining 1)) + ((time-tile 'clear!)) + (draw-time-limit!)))) + + ;tijd verhogen met 1 seconde wanneer pacman een muntje opeet + (define (update-time-limit!) + (set! time-remaining (+ time-remaining 1)) + ((time-tile 'clear!)) + (draw-time-limit!)) + + (define (time-up?) + (= time-remaining 0)))) diff --git a/pp1/PacMan.bmp b/pp1/PacMan.bmp new file mode 100644 index 0000000..42874cc Binary files /dev/null and b/pp1/PacMan.bmp differ diff --git a/pp1/PacMan.png b/pp1/PacMan.png new file mode 100644 index 0000000..1e84be7 Binary files /dev/null and b/pp1/PacMan.png differ diff --git a/pp1/PacMan_mask.png b/pp1/PacMan_mask.png new file mode 100644 index 0000000..443bed0 Binary files /dev/null and b/pp1/PacMan_mask.png differ diff --git a/pp1/main.rkt b/pp1/main.rkt new file mode 100644 index 0000000..663425d --- /dev/null +++ b/pp1/main.rkt @@ -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) \ No newline at end of file diff --git a/pp1/main.rkt~ b/pp1/main.rkt~ new file mode 100644 index 0000000..362a9a3 --- /dev/null +++ b/pp1/main.rkt~ @@ -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)) \ No newline at end of file diff --git a/pp1/pp1/compiled/drracket/errortrace/graphics_rkt.dep b/pp1/pp1/compiled/drracket/errortrace/graphics_rkt.dep new file mode 100644 index 0000000..c1fe649 --- /dev/null +++ b/pp1/pp1/compiled/drracket/errortrace/graphics_rkt.dep @@ -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")) diff --git a/pp1/pp1/compiled/drracket/errortrace/graphics_rkt.zo b/pp1/pp1/compiled/drracket/errortrace/graphics_rkt.zo new file mode 100644 index 0000000..3231333 Binary files /dev/null and b/pp1/pp1/compiled/drracket/errortrace/graphics_rkt.zo differ diff --git a/pp1/pp1/compiled/graphics_rkt.dep b/pp1/pp1/compiled/graphics_rkt.dep new file mode 100644 index 0000000..8909b10 --- /dev/null +++ b/pp1/pp1/compiled/graphics_rkt.dep @@ -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")) diff --git a/pp1/pp1/compiled/graphics_rkt.zo b/pp1/pp1/compiled/graphics_rkt.zo new file mode 100644 index 0000000..e333e6d Binary files /dev/null and b/pp1/pp1/compiled/graphics_rkt.zo differ diff --git a/pp1/pp1/compiled/info_rkt.dep b/pp1/pp1/compiled/info_rkt.dep new file mode 100644 index 0000000..ad3c6de --- /dev/null +++ b/pp1/pp1/compiled/info_rkt.dep @@ -0,0 +1 @@ +("9.1" ta6le ("5a9055df4313931940f2f8fde89a20f87d4a519a" . "c86336a90cbc6d6d5c5a623dc9eb18c4ccfa3e16") (collects #"info" #"main.rkt") (collects #"setup" #"infotab.rkt")) diff --git a/pp1/pp1/compiled/info_rkt.zo b/pp1/pp1/compiled/info_rkt.zo new file mode 100644 index 0000000..cdf74f6 Binary files /dev/null and b/pp1/pp1/compiled/info_rkt.zo differ diff --git a/pp1/pp1/compiled/tests_rkt.dep b/pp1/pp1/compiled/tests_rkt.dep new file mode 100644 index 0000000..31ade28 --- /dev/null +++ b/pp1/pp1/compiled/tests_rkt.dep @@ -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")) diff --git a/pp1/pp1/compiled/tests_rkt.zo b/pp1/pp1/compiled/tests_rkt.zo new file mode 100644 index 0000000..86b274a Binary files /dev/null and b/pp1/pp1/compiled/tests_rkt.zo differ diff --git a/pp1/pp1/graphics.rkt b/pp1/pp1/graphics.rkt new file mode 100644 index 0000000..cde0677 --- /dev/null +++ b/pp1/pp1/graphics.rkt @@ -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-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)) diff --git a/pp1/pp1/graphics.rkt~ b/pp1/pp1/graphics.rkt~ new file mode 100644 index 0000000..cde0677 --- /dev/null +++ b/pp1/pp1/graphics.rkt~ @@ -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-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)) diff --git a/pp1/pp1/info.rkt b/pp1/pp1/info.rkt new file mode 100644 index 0000000..cb459b7 --- /dev/null +++ b/pp1/pp1/info.rkt @@ -0,0 +1,2 @@ +#lang info +(define name "pp1") \ No newline at end of file diff --git a/pp1/pp1/tests.rkt b/pp1/pp1/tests.rkt new file mode 100644 index 0000000..3d2d6e6 --- /dev/null +++ b/pp1/pp1/tests.rkt @@ -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?)) + + ))