I am trying to make a text mover, which is the text will move to where I clicked. Also, when I press "left" key, I can change the color of the text. I think I finished each part the program needs, but I don't know how to put them together now :( I am still confused about how to use on-mouse function.
This is the position of the text part:
(require 2htdp/image)
(require 2htdp/universe)
(define POSN-0 (make-posn 50 50))
(define POSN-1 (make-posn 200 200))
(define POSN-2 (make-posn 100 100))
(define (posn-temp p)
(... (posn-x p) ...
(posn-y p) ...))
This is the color part:
(define Red "red")
(define Black "black")
(define Purple "purple")
(check-expect (RBP Red) "red")
(check-expect (RBP Black) "black")
(check-expect (RBP Purple) "purple")
(define (RBP c)
(cond
[(string=? c Red) "red"]
[(string=? c Black) "black"]
[(string=? c Purple) "purple"]))
This part provides all the information needed for the text-mover application, but I don't know how to use it？？
(define-struct tm [str pos col])
(define T1(make-tm "apple" 10 "red"))
(define T2(make-tm "banana" 20 "black"))
(define (tm-temp tm)
(... (tm-str tm) ...
(tm-pos tm) ...
(tm-col tm) ...))
To-draw:
(define bg (square 400 "solid" "white"))
(check-expect
(draw-tm POSN-0)
(place-image
(text "POG!"
25
"red")
50 50
bg))
(define (draw-tm c)
(place-image
(text "POG!"
25
(RBP c))
50 50
bg))
On-key:
(define (change-c c ke)
(cond
[(key=? ke "left") (RBP c)]
[else c]))
On-mouse:
(define (move-tm c )
(cond
[(mouse=? ) ]
[else c]))
Big-bang:
(define (move-text initial-tm)
(big-bang initial-tm
[to-draw draw-tm]
[on-mouse move-tm]
[on-key change-c]))
Read on-mouse description: function called with on-mouse has arguments state x y event and different types of mouse events are described in Mouse event docs. In your case, you will need "button-up" or "drag".
Also, when x or y or color changes, you have to create new instance of struct which represents state, using data from old instance.
Here is example code- run it with (move-text "FooBar"), you can drag displayed text into new position or change color with left key.
(require 2htdp/image)
(require 2htdp/universe)
(define-struct text-state [text position color])
(define (next-color color)
(second (assoc color (list (list "black" "red")
(list "red" "purple")
(list "purple" "black")))))
(define bg (square 400 "solid" "white"))
(define (draw-state state)
(place-image
(text (text-state-text state)
25
(text-state-color state))
(posn-x (text-state-position state))
(posn-y (text-state-position state))
bg))
(define (change-color state key)
(if (key=? key "left")
(make-text-state (text-state-text state)
(text-state-position state)
(next-color (text-state-color state)))
state))
(define (mouse-fn state x y event)
(if (string=? "drag" event)
(make-text-state
(text-state-text state)
(make-posn x y)
(text-state-color state))
state))
(define (move-text text)
(big-bang (make-text-state text (make-posn 50 50) "black")
[to-draw draw-state]
[on-mouse mouse-fn]
[on-key change-color]))
I have a problem with move function in my code.
I need it to be :
one function which can move all shapes or,
multiple functions with the same name.
So far I have move functions with diffrent names for point, circle and polygon.
I can't figure out how to make move function for picture.
If you guys can help me with that move function for picture and edit all the move function so they work like I described at beginning.
;
; POINT
;
(defun make-point ()
(list (list 0 0) :black))
(defun x (point)
(caar point))
(defun y (point)
(cadar point))
(defun set-x (point new-x)
(setf (caar point) new-x)
point)
(defun set-y (point new-y)
(setf (cadar point) new-y)
point)
(defun move (point dx dy)
(set-x point (+ (x point) dx))
(set-y point (+ (y point) dy))
point)
;
; CIRCLE
;
(defun make-circle ()
(list (make-point) 1 :black))
(defun center (circle)
(car circle))
(defun radius (circle)
(cadr circle))
(defun set-radius (circle new-rad)
(if (> 0 new-rad)
(format t "Polomer ma byt kladne cislo, zadali ste : ~s" new-rad)
(setf (cadr circle) new-rad))
circle)
(defun movec (circle dx dy)
(move (center circle) dx dy)
circle)
;
; POLYGON
;
(defun make-polygon ()
(list nil :black))
(defun items (shape)
(car shape))
(defun set-items (shape val)
(setf (car shape) val)
shape)
(defun movep (polygon dx dy)
(mapcar (lambda (b) (move b dx dy)) (items polygon))
polygon)
;
; PICTURE
;
(defun make-picture ()
(list nil :black))
;(defun movepi (picture dx dy))
; items, set-items used for polygon and picture
Your objects are just lists, you will have a hard time distinguishing among different kinds of shapes. You could add a keyword, a tag type, in front of your lists (e.g. :point, :circle, etc.) to better dispatch your move operations according to that tag, but then that would be reinventing the wheel, a.k.a. objects.
Simple functions and lists
one function which can move all shapes
You can do that, provided you can dispatch on the actual type of object you are working with. move should be able to know what kind of shape is being moved. Change your data-structures if you can to add the type of object as the CAR of your lists, and use a CASE to dispatch and then move each object as needed.
or multiple functions with the same name.
This is not possible, at least in the same package.
CLOS
(defpackage :pic (:use :cl))
(in-package :pic)
Multiple shapes have a color, so let's define a class that represent objects which have a color component:
(defclass has-color ()
((color :initarg :color :accessor color)))
If you are unfamiliar with CLOS (Common Lisp Object System), the above defines a class named has-color, with no superclass and a single slot, color. The accessor names both the reader and writer generic functions, such that you can do (color object) to retrieve an object, and (setf (color object) color) to set the color of an object to a color. The :initarg is used to define the keyword argument that is to be used in make-instance.
Here below, we define a point, which has a color and additional x and y coordinates.
(defclass point (has-color)
((x :initarg :x :accessor x)
(y :initarg :y :accessor y)))
The same for a circle:
(defclass circle (has-color)
((center :initarg :center :accessor center)
(radius :initarg :radius :accessor radius)))
And a polygon:
(defclass polygon (has-color)
((points :initarg :points :accessor points)))
Finally, a picture is a sequence of shapes:
(defclass picture ()
((shapes :initarg :shapes :accessor shapes)))
You can make a circle as follows:
(make-instance 'circle
:center (make-instance 'point :x 10 :y 30)
:color :black))
You could also define shorter constructor functions, if you wanted.
Now, you can use a generic function to move your objects. You first define it with DEFGENERIC, which declares the signature of the generic function, as well as additional options.
(defgeneric move (object dx dy)
(:documentation "Move OBJECT by DX and DY"))
Now, you can add methods to that generic function, and your generic function will dispatch to them based on one or more specializers and/or qualifiers.
For example, you move a point as follows:
(defmethod move ((point point) dx dy)
(incf (x point) dx)
(incf (y point) dy))
You can see that we specialize move based on the class of the first parameter, here named point. The method is applied when the value bound to point is of class point. The call to INCF implicitly calls (setf x) and (setf y), defined above.
Moving a circle means moving its center:
(defmethod move ((circle circle) dx dy)
(move (center circle) dx dy))
You can specialize a generic function on any class, for example the standard SEQUENCE class. It moves all the objects in the sequence with the same offsets:
(defmethod move ((sequence sequence) dx dy)
(map () (lambda (object) (move object dx dy)) sequence))
This is useful for polygons:
(defmethod move ((polygon polygon) dx dy)
(move (points polygon) dx dy))
And also for pictures:
(defmethod move ((picture picture) dx dy)
(move (shapes picture) dx dy))
Immutable version
You could also make move build new instances, but that requires to somehow make copies of existing objects. A simple approach consists in having a generic function which fills a target instance with a source instance:
(defgeneric fill-copy (source target)
(:method-combination progn))
The method combination here means that all methods that satisfy fill-copy are run, instead of only the most specific one. The progn suggests that all methods are run in a progn block, one after the other. With the above definition, we can define a simple copy-object generic function:
(defgeneric copy-object (source)
(:method (source)
(let ((copy (allocate-instance (class-of source))))
(fill-copy source copy)
copy)))
The above defines a generic function named copy-object, as well as a default method for an object of type T (any object).
ALLOCATE-INSTANCE creates an instance but does not initialize it. The method uses FILL-COPY to copy slot values.
You can for example define how to copy the color slot of any object that has a color:
(defmethod fill-copy progn ((source has-color) (target has-color))
(setf (color target) (color source)))
Notice that you have multiple dispatch here: both the source and target objects must be of class has-color for the method to be called. The progn method combination allows to distribute the job of fill-copy among different, decoupled, methods:
(defmethod fill-copy progn ((source point) (target point))
(setf (x target) (x source))
(setf (y target) (y source)))
If you give a point to fill-copy, two methods can be applied, based on the class hierarchy of point: the one defined for has-color, and the one specialized on the point class (for both arguments). The progn method combination ensures both are executed.
Since some slots can be unbound, it is possible that fill-copy fails. We can remedy to that by adding an error handler around fill-copy:
(defmethod fill-copy :around (source target)
(ignore-errors (call-next-method)))
The (call-next-method) form calls the other methods (those defined by the progn qualifier), but we wrap it inside ignore-errors.
Here no color is defined, but the copy succeeds:
(copy-object (make-point :x 30 :y 20))
=> #<POINT {1008480D93}>
We can now keep our existing, mutating, move methods, and wrap them in a :around specialized method that first make a copy:
(defmethod move :around (object dx dy)
;; copy and mutate
(let ((copy (copy-object object)))
(prog1 copy
(call-next-method copy dx dy))))
In order to see what happens, define a method for PRINT-OBJECT:
(defmethod print-object ((point point) stream)
(print-unreadable-object (point stream :identity t :type t)
(format stream "x:~a y:~a" (x point) (y point))))
And now, moving a point creates a new point:
(let ((point (make-instance 'point :x 10 :y 20)))
(list point (move point 10 20)))
=> (#<POINT x:10 y:20 {1003F7A4F3}> #<POINT x:20 y:40 {1003F7A573}>)
You would still need to change the method for the SEQUENCE type, which currently discards the return values of move, but apart from that there is little change to make to existing code.
Note also that the above approach is mostly used as a way to describe the various uses of CLOS, and in practice you would probably choose one way or another to move points (mutable or not), or you would have different functions instead of a single generic one (e.g. mut-move and move).
Rough sketch, tag shapes:
(defun p (x y) (list x y))
(defun make-shape (type points colour data)
(list* type points colour data))
(defmacro defshape (name args &key verify-points verify-args)
"define the function (make-NAME points ARGS...)
to make a shape of type :NAME. Optionally
evaluate the form VERIFY-ARGS with the
lambda-list ARGS bound and call the
function VERIFY-POINTS with the points of
the shape, ignoring its result."
(let ((type (intern name (symbol-package :key)))
(fun (intern (concatenate 'String "MAKE-" name) (symbol-package name)))
(all (gensym "ARGS"))
(colour (gensym "COLOUR"))
(points (gensym "POINTS")))
`(defun ,fun (,points ,colour &rest ,all)
(destructuring-bind ,args ,all
,verify-args
,(if verify-points `(funcall ,verify-points ,points))
(make-shape ,type ,points ,colour ,all))))
(defun singlep (list) (and list (null (cdr list))))
(defshape point () :verify-points #'singlep
(defshape circle (radius) :verify-args (assert (realp radius) radius)
:verify-points #'singlep)
(defshape polygon ())
You can use this:
CL-USER> (make-circle (list (p 0 0)) :black 2)
(:CIRCLE ((0 0)) :BLACK)
CL-USER> (make-point (list (p 1 2)) :blue)
(:POINT ((1 2)) :BLUE)
CL-USER> (make-polygon (list (p 0 0) (p 0 1) (p 1 0)) :red)
(:POLYGON ((0 0) (0 1) (1 0)) :RED)
And you can write some functions:
(defun map-points (function shape)
(destructuring-bind (type points colour &rest data)
shape
(make-shape type (mapcar function points) colour data)))
And apply them:
CL-USER> (map-points (lambda (p) (list (1+ (first p)) (second p))) '(:POLYGON ((0 0) (0 1) (1 0)) :RED))
(:POLYGON ((1 0) (1 1) (2 0)) :RED)
And solve your problem:
(defun move (dx dy shape)
(map-points (lambda (p) (destructuring-bind (x y) p (list (+ x dx) (+ y dy)))) shape))
Another thing you might want is a big case based on the type (ie CAR) of the shape, of you dispatch based on mapping the type to something in a hash table, or putting something in its symbol plist.
I am currently trying to code 'Breakout' in BSL but I'm stuck as I
don't know how to add a welcome and a game-over screen to my code. It is
supposed that the game starts with the welcome screen and when it is
clicked with the mouse on the screen the actual game should start. When
the ball collides with the lower edge of the screen a game-over-screen
is supposed to appear.
I appreciate any tips given!
(define WIDTH 200)
(define HEIGHT 200)
(define BALL-RADIUS 10)
(define BALL-IMG (circle BALL-RADIUS "solid" "red"))
(define MT (empty-scene WIDTH HEIGHT))
(define GAME-OVER
(place-image (text "Game-over" 30 "black")
100 100
MT))
(define WELCOME
(place-image (text "Welcome" 30 "black")
100 100
MT))
(define-struct vel (delta-x delta-y))
; a Vel is a structure: (make-vel Number Number)
; interp. the velocity vector of a moving object
(define-struct ball (loc velocity))
; a Ball is a structure: (make-ball Posn Vel)
; interp. the position and velocity of a object
(define RACKET (rectangle 30 10 "solid" "grey"))
(define-struct world-state (ball racket))
; A WorldState is a structure. (make-world-state Ball Location of
Racket)
; interp. current velocity and location of ball, current location of
racket
; Posn Vel -> Posn
; applies q to p and simulates the movement in one clock tick
(check-expect (posn+vel (make-posn 5 6) (make-vel 1 2))
(make-posn 6 8))
(define (posn+vel p q)
(make-posn (+ (posn-x p) (vel-delta-x q))
(+ (posn-y p) (vel-delta-y q))))
; Ball -> Ball
; computes movement of ball in one clock tick
(define (move-ball ball)
(make-ball (posn+vel (ball-loc ball)
(ball-velocity ball))
(ball-velocity ball)))
; A Collision is either
; - "top"
; - "down"
; - "left"
; - "right"
; - "racket"
; - "none"
; interp. the location where a ball collides with a wall
; Posn -> Collision
; detects with which of the walls (if any) or the racket the ball
collides
(define (collision world-state)
(cond
[(<= (posn-x (ball-loc (world-state-ball world-state))) BALL-
RADIUS) "left"]
[(<= (posn-y (ball-loc (world-state-ball world-state))) BALL-
RADIUS) "top"]
[(>= (posn-x (ball-loc (world-state-ball world-state))) (- WIDTH
BALL-RADIUS)) "right"]
[(>= (posn-y (ball-loc (world-state-ball world-state))) (- HEIGHT
BALL-RADIUS)) "down"]
[(and (>= (posn-y (ball-loc (world-state-ball world-state))) (-
HEIGHT BALL-RADIUS 10))
(<= (- (posn-x (world-state-racket world-state)) 15)
(posn-x (world-state-racket world-state))
(+ (posn-x (world-state-racket world-state)) 15)))
"racket"]
[else "none"]))
; Vel Collision -> Vel
; computes the velocity of an object after a collision
(define (bounce vel collision)
(cond [(or (string=? collision "left")
(string=? collision "right"))
(make-vel (- (vel-delta-x vel))
(vel-delta-y vel))]
[(or (string=? collision "top")
(string=? collision "racket"))
(make-vel (vel-delta-x vel)
(- (vel-delta-y vel)))]
[else vel]))
; render
; WorldState -> Image
; renders ball and
racket at their position
(check-expect (image? (render INITIAL-STATE)) #true)
(define (render world-state)
(place-image BALL-IMG
(posn-x (ball-loc (world-state-ball world-state)))
(posn-y (ball-loc (world-state-ball world-state)))
(place-image RACKET
(posn-x (world-state-racket world-state))
195
(empty-scene WIDTH HEIGHT))))
;tick
; WorldState -> WorldState
; moves ball to its next location
(check-expect (tick INITIAL-STATE) (make-world-state (make-ball (make-posn 21 14) (make-vel 1 2)) (make-posn 20 195)))
(define (tick world-state)
(make-world-state (move-ball (make-ball (ball-loc (world-state-ball world-state))
(bounce (ball-velocity (world-state-ball world-state))
(collision world-state))))
(world-state-racket world-state)))
; A Location is a structure: (make-posn Number Number)
; interp. x and y coordinate of a location on screen.
(define Loc (make-posn 1 1))
; A MouseEvent is one of
; - "button-down"
; - "button-up"
; - "drag"
; - "move"
; - "enter"
; - "leave"
; interp. mouse events, e.g., mouse movements or mouse clicks
(define MOUSE-CLICK "button-down")
; mouse
;
; Game Number Number MouseEvent -> WorldState
; Update position of racket when the mouse moves
;mouse-template
(define (mouse-template world-state mouse-loc-x mouse-loc-y MouseEvent)
(cond
((string=? MouseEvent "button-down")...)
((string=? MouseEvent "button-up")...)
((string=? MouseEvent "drag")...)
((string=? MouseEvent "move")...)
((string=? MouseEvent "enter")...)
((string=? MouseEvent "leave")...)
(else ...)))
(define (mouse world-state mouse-loc-x mouse-loc-y MouseEvent)
(cond
[(and (string=? MouseEvent "move")
(>= mouse-loc-y 180))
(make-world-state (world-state-ball world-state)
(make-posn mouse-loc-x 195))]
[else world-state]))
(define INITIAL-BALL (make-ball (make-posn 20 12)
(make-vel 1 2)))
(define INITIAL-RACKET (make-posn 20 195))
(define INITIAL-STATE (make-world-state INITIAL-BALL INITIAL-RACKET))
; WorldState -> WorldState
; Starts the game
(define (main state)
(big-bang state
(on-tick tick 0.01)
(to-draw render)
(on-mouse mouse)))
; start with INITIAL-STATE
You now have three different states:
welcome
playing
game-over
So far you have only had "playing" and you used your world structure to represent that.
Now you need to introduce two new structures: welcome and game-over.
Rename your old render function render-world (or render-playing).
Then write something like:
(define (render w)
(cond
[(welcome? w) (render-welcome w)]
[(world? w) (render-world w)]
[(game-over? w) (render-game-over w)]))
Of course your initial state should become an instance of welcome, and you also need three different tick functions.
I am trying to implement the guess my number game in racket, and in a functional way, for educational purposes. My problem is that I have to stop the function with an error as in (error "YOU GUESSED!"). The error function is what I could find in the racket documentation. Is there an errorless way to stop this conditional?
Note: I read about stop-when, but I don't want to go into big-bang yet.
(define guess-my-number (lambda ()
(letrec ([my-number (random 100)]
[choices-left 7]
[game (lambda (choices-left)
(if (> choices-left 0)
(let ([user-guess (read)])
(cond [(> user-guess my-number) (display "That was too high!")]
[(< user-guess my-number) (display "That was too small!")]
[(= user-guess my-number) (error "YOU GUESSED!")])
(game (- choices-left 1)))
(display "Here ends the game!!")))])
(game choices-left))))
Chris' answer is perfect. This is really a comment -- except it's a bit long and you can't do code blocks in comments here.
The way you're coding it is a great way to understand how Racket works at a "low level", and is a very traditional way to code this in Scheme.
Another traditional way in Scheme is to use a couple features:
The shorthand way to define a function.
A named let, using the typical name loop.
That version:
(define (guess-my-number-v2)
(let ([number (random 100)])
(let loop ([guesses-left 7])
(cond [(> guesses-left 0)
(define user-guess (read))
(cond [(> user-guess number)
(display "That was too high!")
(loop (sub1 guesses-left))]
[(< user-guess number)
(display "That was too low!")
(loop (sub1 guesses-left))]
[else (display "YOU GUESSED!")])]
[else
(displayln "Here ends the game!!")]))))
What's interesting is that this expands to almost exactly the same thing as your first version.
The (let loop (guesses-left 7]) ...) form is essentially defining a function named loop, much like your original one named game. (In fact you could say (let game ([guesses-left 7]) ...), too.)
One benefit is that it's not as deeply indented and doesn't march off the right side of the screen.
Finally here's a version that's a bit more "Racket-y" in making more use of define:
(define (guess-my-number-v3)
(define number (random 100))
(define (guess guesses-left)
(cond [(> guesses-left 0)
(define user-guess (read))
(cond [(> user-guess number)
(display "That was too high!")
(guess (sub1 guesses-left))]
[(< user-guess number)
(display "That was too low!")
(guess (sub1 guesses-left))]
[else (display "YOU GUESSED!")])]
[else
(displayln "Here ends the game!!")]))
(guess 7))
Although this is in more of a "modern" Racket style, it's not inherently "better". It, too expands to almost exactly the same thing as the original. In fact most Racket programmers would find all 3 styles easy to understand.
Anyway, all 3 versions "loop" by recursively calling a function, as you were already doing. The way to "terminate the loop" is simply... don't call the function again. That's the key point in Chris' answer.
Yes. Do the (game (- choices-left 1)) recursion inside the cond branches where you want to reloop:
(define guess-my-number (lambda ()
(letrec ([my-number (random 100)]
[choices-left 7]
[game (lambda (choices-left)
(if (> choices-left 0)
(let ([user-guess (read)])
(cond [(> user-guess my-number) (display "That was too high!")
(game (- choices-left 1))]
[(< user-guess my-number) (display "That was too small!")
(game (- choices-left 1))]
[(= user-guess my-number) (display "YOU GUESSED!")]))
(display "Here ends the game!!")))])
(game choices-left))))
This my code:
#lang racket
(require racket/gui)
(define-values (screen-width screen-height) (get-display-size))
(define *app-width* 400)
(define *app-height* 125)
(define *vm-frame* (new frame%
[label "Test"]
[width *app-width*]
[height *app-height*]
[x (- (quotient screen-width 2) (quotient *app-width* 2))]
[y (- (quotient screen-height 2) (quotient *app-height* 2))]
))
(define frame-canvas%
(class canvas%
(super-new)
(inherit get-dc)
(define/override (on-paint)
(let ([my-dc (get-dc)])
(send my-dc clear)
(send my-dc set-background "black")))))
(let ([frame-canvas (new frame-canvas% [parent *vm-frame*])])
(send *vm-frame* show #t))
On mac os, this is normal, show a app with a black background.
But on windows, background is white.
Why? Racket version is 5.3, it's a 5.3 bug?
Reverse the order of set-background and clear.
The call to clear uses the color of the current background to do the fill. If somehow your on-paint were called at least more than once, then you would observe a black background, since the second time around, the current background color would be black. I suspect this is what explains the platform-specific difference you observed.