I am going to design an interactive weekly exercise calendar. The program displays the current day and associated exercise, as allows the user to scroll forward/backward in the week by pressing the right/left arrow keys, respectively. When I finished coding, there are some problems in the to-draw and on-key part.
(require 2htdp/image)
(require 2htdp/universe)
(define SUNDAY "Sunday Climbing")
(define MONDAY "Monday Cardio")
(define TUESDAY "Tuesday Upper body+Core")
(define WEDNESDAY "Wednesday Cardio")
(define THURSDAY "Thursday Lower Body + Core")
(define FRIDAY "Friday Cardio")
(define SATURDAY "Saturday Rest")
(check-expect (exercise SUNDAY) "Sunday Climbing")
(check-expect (exercise MONDAY) "Monday Cardio")
(define (exercise e-day)
(cond
[(string=? e-day SUNDAY) SUNDAY]
[(string=? e-day MONDAY) MONDAY]
[(string=? e-day TUESDAY) TUESDAY]
[(string=? e-day WEDNESDAY) WEDNESDAY]
[(string=? e-day THURSDAY) THURSDAY]
[(string=? e-day FRIDAY) FRIDAY]
[(string=? e-day SATURDAY) SATURDAY]))
Next week function:
(check-expect (next-weekday SUNDAY) MONDAY)
(check-expect (next-weekday MONDAY) TUESDAY)
(define (next-weekday d)
(cond
[(string=? d SUNDAY) MONDAY]
[(string=? d MONDAY) TUESDAY]
[(string=? d TUESDAY) WEDNESDAY]
[(string=? d WEDNESDAY) THURSDAY]
[(string=? d THURSDAY) FRIDAY]
[(string=? d FRIDAY) SATURDAY]
[(string=? d SATURDAY) SUNDAY]))
Previous week function:
(check-expect (prev-weekday SUNDAY) SATURDAY)
(check-expect (prev-weekday MONDAY) SUNDAY)
(define (prev-weekday d)
(cond
[(string=? d SUNDAY) SATURDAY]
[(string=? d MONDAY) SUNDAY]
[(string=? d TUESDAY) MONDAY]
[(string=? d WEDNESDAY) TUESDAY]
[(string=? d THURSDAY) WEDNESDAY]
[(string=? d FRIDAY) THURSDAY]
[(string=? d SATURDAY) FRIDAY]))
big-bang:
(define (exercise-calendar initial-d)
(big-bang initial-d
[to-draw draw-day]
[on-key move-day]))
(define BACKGROUND (square 200 "solid" "white"))
(define WEEKDAY(text (exercise e-day) 36 "blue"))
(check-expect
(draw-day day)
(place-image
WEEKDAY
50 50
BACKGROUND))
(define
(draw-day day)
(place-image
WEEKDAY
50 50
BACKGROUND))
(define (move-day p ke)
(cond
[(key=? ke "left") (prev-weekday p)]
[(key=? ke "right") (next-weekday p)]
[else p]))
Just some notes:
This part (define WEEKDAY (text (exercise e-day) 36 "blue")) can't be evaluated, because value of e-day isn't known. You can rewrite it as function with argument e-day, or move it directly into draw-day function.
Don't repeat string=? in next-weekday and prev-weekday. You can use some data structure and fetch data with assoc.
If those check-expect tests are given to you by teacher, you should mark them somehow like this "I have to use this code and can't change it and I have to pass exactly these tests". I didn't find note like this, so I rewrote them to suit my solution.
Rest of the code is similar:
(require 2htdp/image)
(require 2htdp/universe)
(define (exercise day)
(second (assoc day (list (list "Sunday" "Sunday Climbing")
(list "Monday" "Monday Cardio")
(list "Tuesday" "Tuesday Upper body+Core")
(list "Wednesday" "Wednesday Cardio")
(list "Thursday" "Thursday Lower Body + Core")
(list "Friday" "Friday Cardio")
(list "Saturday" "Saturday Rest")))))
(define (next-weekday day)
(second (assoc day (list (list "Sunday" "Monday")
(list "Monday" "Tuesday")
(list "Tuesday" "Wednesday")
(list "Wednesday" "Thursday")
(list "Thursday" "Friday")
(list "Friday" "Saturday")
(list "Saturday" "Sunday")))))
(define (prev-weekday day)
(second (assoc day (list (list "Sunday" "Saturday")
(list "Monday" "Sunday")
(list "Tuesday" "Monday")
(list "Wednesday" "Tuesday")
(list "Thursday" "Wednesday")
(list "Friday" "Thursday")
(list "Saturday" "Friday")))))
(check-expect (exercise "Sunday") "Sunday Climbing")
(check-expect (exercise "Monday") "Monday Cardio")
(check-expect (next-weekday "Sunday") "Monday")
(check-expect (next-weekday "Monday") "Tuesday")
(check-expect (prev-weekday "Sunday") "Saturday")
(check-expect (prev-weekday "Monday") "Sunday")
(define bg (square 500 "solid" "white"))
(define (draw-day day)
(place-image (text (exercise day) 18 "blue") 250 50 bg))
(define (move-day day key)
(cond
[(key=? key "left") (prev-weekday day)]
[(key=? key "right") (next-weekday day)]
[else day]))
(define (exercise-calendar day)
(big-bang day
[to-draw draw-day]
[on-key move-day]))
Start with (exercise-calendar "Monday") and press left and right key.
Related
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]))
How can I get the number of days between the given years, should I use loops?
Here's what I have now
(princ "Enter starting year: ")
(defparameter w (read))
(princ "Enter ending year: ")
(defparameter x (read))
(defun print-list (w x)
(format t "Starting year: ~a ~%" (list w))
(format t "Ending year: ~a ~%" (list x)))
(terpri)
(if(> x w)
(format t "Number of year/s: ~a ~%"(- x w))
(format t "Number of year/s: ~a ~%"(- w x)))
I'm trying to compute the days between years but the output was always failed.
A simple set of functions to perform the calculation is the following:
(defun leap-year-p (year)
"return t if year is a leap-year, nil otherwise"
(or (and (zerop (mod year 4))
(not (zerop (mod year 100))))
(zerop (mod year 400))))
(defun days-of (year)
"return the number of days of a certain year"
(if (leap-year-p year) 365 366))
(defun days-between (start-year end-year)
"return the number of days between start-year (included)
and end-year (excluded)"
(when (<= start-year end-year)
(loop for year from start-year below end-year sum (days-of year)))
A few examples of call:
CL-USER> (days-between 2020 2022)
731
CL-USER> (days-between 1820 1999)
65470
CL-USER> (days-between 2020 2020)
0
CL-USER> (days-between 1980 1890)
NIL
You can use these function to solve your problem.
I'm designing a game for a class where:
A colored dot appears from the right side of the screen and moves across the screen to the left on a fixed horizontal axis.
When the dot reaches the middle, the player needs to press a key corresponding to its color. If done at the right time, the score increases by one.
If not, the player loses one life.
I'm having trouble with the following:
[SOLVED] Adding a new dot to the list of dots at random intervals in the game. This will make it so the dots don't appear linearly, and two dots can be generated right after one another.
[SOLVED] Moving the dots across the screen left to right.
[SOLVED] Removing the correct dot when it's in the hitbox area.
Removing a life if a dot goes offscreen.
The language used here is intermediate student with lambda.
Currently, when I press 1 for red, it will remove it as long as a red dot is the first in the list. I need a function that removes that specific red dot.
Here's the code so far; know that it's not finished and thus not working as I intend it to.
; Color Match
; Game structures
(define-struct dot [x color])
(define-struct cm [dots score lives state])
; Constants
(define width 800)
(define height (/ width (/ 16 9)))
(define h-w (/ width 2))
(define h-h (/ height 2))
(define arrow (beside (rectangle 25 10 "solid" "black")
(rotate 135 (right-triangle 18 18 "solid" "black"))))
(define background (empty-scene width height))
(define bars (place-images
(list
(circle (/ width 25) "outline" "black")
(rectangle (+ width 2) (- height 375) "outline" "black"))
(list
(make-posn h-w h-h)
(make-posn h-w h-h))
background))
; Game
(define (main ws)
(big-bang (make-cm empty 0 3 "start")
[on-tick tock]
[to-draw render]
[on-release interact]
))
;; random-color: number -> string
;; consumes a number and returns a color
;; string for the given number
(define (random-color n)
(cond
[(= n 0) "red"]
[(= n 1) "blue"]
[(= n 2) "green"]
[(= n 3) "yellow"]
[else (error "Invalid color chosen.")]))
;; draw-dot: structure -> image
;; consumes a dot structure and draws it as an image
(define (draw-dot struct)
(cond
[(string=? (dot-color struct) "red") (overlay
(rotate 90 arrow)
(circle (/ width 25) "outline" "black")
(circle (/ width 25) "solid" (dot-color struct)))]
[(string=? (dot-color struct) "blue") (overlay
(rotate 270 arrow)
(circle (/ width 25) "outline" "black")
(circle (/ width 25) "solid" (dot-color struct)))]
[(string=? (dot-color struct) "green") (overlay
(flip-horizontal arrow)
(circle (/ width 25) "outline" "black")
(circle (/ width 25) "solid" (dot-color struct)))]
[(string=? (dot-color struct) "yellow") (overlay
arrow
(circle (/ width 25) "outline" "black")
(circle (/ width 25) "solid" (dot-color struct)))]))
;; tock: color-match -> color-match
;; placeholder for later worldstate
(define (tock ws)
(cond
[(string=? (cm-state ws) "play")
(make-cm (move-dots (add-dot? (random 50) (cm-dots ws)))
(+ (cm-score ws) 1)
(cm-lives ws)
"play")]
[else ws]))
;; add-dot?: number, list of dots -> list of dots
;; consumes list of dots and number and adds a new dot
;; to the list of dots
(define (add-dot? n lod)
(cond
[(= n 1) (cons (make-dot (+ width 25) (random-color (random 4))) lod)]
[else lod]))
;; render: color-match -> image
;; consumes the current color-match structure and calls the appropriate
;; helper function.
(define (render ws)
(cond
[(string=? (cm-state ws) "start") (render-start ws)]
[(string=? (cm-state ws) "play") (render-play ws)]
[(string=? (cm-state ws) "pause") (render-pause ws)]
[else (error "Invalid gamestate chosen.")]))
;; render-start: color-match -> image
;; helps the render function by displaying the current state
;; as an image.
(define (render-start ws)
(place-image
(above
(text "Instructions" (/ width 20) "red")
(text "Colored shapes will begin appearing from the right of the screen." (/ width 50) "black")
(text "Once they reach the bar in the middle, press the appropriate key." (/ width 50) "black")
(text "1: Red" (/ width 50) "red")
(text "2: Blue" (/ width 50) "blue")
(text "3: Green" (/ width 50) "green")
(text "4: Yellow" (/ width 50) "yellow"))
h-w
h-h
background))
;; draw-dots: list of dots -> image
;; consumes a list of dots and draws them
;; according to their color
(define (draw-dots lod)
(cond
[(empty? lod) bars]
[else (place-image (draw-dot (first lod))
(dot-x (first lod))
h-h
(draw-dots (rest lod)))]))
;; is-visible?: dot -> boolean
;; consumes a dot and determines if it is currently visible
;; on the canvas
(define (is-visible? dot)
(cond
[(> (dot-x dot) -25) #true]
[else #false]))
;; move-dot: dot -> number
;; consumes a dot and returns its new
;; x coordinate
(define (move-dot dot)
(- (dot-x dot) 10))
;; new-dot: dot -> dot
;; consumes a dot and returns a new dot by calling
;; the move-dot function
(define (new-dot dot)
(make-dot (move-dot dot) (dot-color dot)))
;; move-dots: list of dots -> list of dots
;; consumes a list of dots and moves them across the
;; canvas as long as they are in view
(define (move-dots lod)
(cond
[(empty? lod) empty]
[(not (is-visible? (first lod))) (rest lod)]
[else (cons (new-dot (first lod)) (move-dots (rest lod)))]))
;; draw-bars: cm -> image
;; consumes the world state and returns the image of bars
(define (draw-bars ws)
(place-image (draw-dots (cm-dots ws))
h-w
h-h
bars))
;; render-play: color-match -> image
;; helps the render function by displaying the current state
;; as an image.
(define (render-play ws)
(overlay/align "left" "top" (current-lives ws)
(underlay/align "right" "top" (place-image (draw-bars ws)
h-w
h-h
background)
(current-score ws))))
;; current-lives: cm -> image
;; consumes the worldstate and displays the
;; current life count
(define (current-lives ws)
(text (string-append "Lives: " (number->string (cm-lives ws))) 18 "red"))
;; current-score: cm -> image
;; consumes the worldstate and shows the
;; current score
(define (current-score ws)
(text (string-append "Score: " (number->string (cm-score ws))) 18 "black"))
;; render-pause: color-match -> image
;; helps the render function by displaying the current state
;; as an image.
(define (render-pause ws)
(place-image
(text "paused" (/ width 20) "red")
h-w
(- h-h 75)
(render-play ws)))
; (define (check-dot lod key)
; (cond
; [(empty? lod) empty]
; [(and (< (- h-w (+ (/ width 25) 25)) (dot-x (first lod)) (+ h-w (+ (/ width 25) 25))) (string=? (dot-color (first lod)) "red") (key=? key "1")) (remove (make-dot (dot-x (first lod)) "red") lod)]
; [(and (< (- h-w (+ (/ width 25) 25)) (dot-x (first lod)) (+ h-w (+ (/ width 25) 25))) (string=? (dot-color (first lod)) "blue") (key=? key "2")) (remove (make-dot (dot-x (first lod)) "blue") lod)]
; [(and (< (- h-w (+ (/ width 25) 25)) (dot-x (first lod)) (+ h-w (+ (/ width 25) 25))) (string=? (dot-color (first lod)) "green") (key=? key "3")) (remove (make-dot (dot-x (first lod)) "green") lod)]
; [(and (< (- h-w (+ (/ width 25) 25)) (dot-x (first lod)) (+ h-w (+ (/ width 25) 25))) (string=? (dot-color (first lod)) "yellow") (key=? key "4")) (remove (make-dot (dot-x (first lod)) "yellow") lod)]
; [else lod]))
;; correct-dot? cm, lod, string -> list of dots
;; consumes the world state, its list of dots, a string, and sorts
;; out dots that have been correctly selected
(define (correct-dot? lod c)
(cond
[(empty? lod) empty]
[(and (< (- h-w (+ (/ width 25) 1)) (dot-x (first lod)) (+ h-w (+ (/ width 25) 1))) (string=? (dot-color (first lod)) c)) (correct-dot? (rest lod) c)]
[else (cons (first lod) (correct-dot? (rest lod) c))]))
;; is-it?: list of dots, key -> list of dots
;; consumes a list of dots and a key and returns
;; a new list of dots with one removed if the
;; conditions are met for it
(define (is-it? lod key)
(cond
[(empty? lod) empty]
[(key=? key "up") (correct-dot? lod "red")]
[(key=? key "down") (correct-dot? lod "blue")]
[(key=? key "left") (correct-dot? lod "green")]
[(key=? key "right") (correct-dot? lod "yellow")]
[else lod]))
;; interact: color-match, key -> color-match
;; consumes the current color-match state and returns
;; a new one depending on which key is pressed.
(define (interact ws key)
(cond
[(string=? (cm-state ws) "play")
(cond
[(key=? key "p") (make-cm (cm-dots ws)
(cm-score ws)
(cm-lives ws)
"pause")]
[else (make-cm (is-it? (cm-dots ws) key)
(cm-score ws)
(cm-lives ws)
(cm-state ws))])]
[(and (string=? (cm-state ws) "start") (key=? key "p")) (make-cm (cm-dots ws)
(cm-score ws)
(cm-lives ws)
"play")]
[(and (string=? (cm-state ws) "pause") (key=? key "p")) (make-cm (cm-dots ws)
(cm-score ws)
(cm-lives ws)
"play")]
[else ws]))
(main 200)
In ISL lists are not mutable so the only thing that you are able to do is create a new list with everything except what you want to remove. You could possibly filter through the list with your procedure only accepting the elements you want to keep
Use accumulative recursion to write a function called update-balance that consumes a list of transactions, lot, a starting balance at the beginning of the month (considered day 0), start-bal, and a non-‐negative number representing a minimum balance, min-bal. The function produces the balance of a bank account after completing all of the transactions in lot.
Having a problem with use of accumulative recursion
(define (trans-val t start-bal min-bal)
(cond
[(symbol=? (trans-action t) 'withdraw)
(cond
[(>= (- start-bal (trans-amt t)) min-bal)
(- start-bal (trans-amt t))]
[else (- start-bal (+ 1 (trans-amt t)))])]
[else
(cond
[(>= (+ start-bal (trans-amt t)) min-bal)
(+ start-bal (trans-amt t))]
[else (+ start-bal (- (trans-amt t) 1))])]))
Maybe something like this?
(define (update-balance lot start-bal min-bal)
(if (null? lot)
; no more transactions to process -> return start-bal
start-bal
; take next transaction (t), calculate new balance
(let* ((t (car lot))
(new-bal ((if (eq? (trans-action t) 'withdraw) - +)
start-bal
(trans-amt t))))
; if new balance >= minimum balance, use that, otherwise retain previous balance
; in any case, tail-recursively call update-balance to process the next transaction
(update-balance (cdr lot)
(if (>= new-bal min-bal) new-bal start-bal)
min-bal))))
Testing:
> (update-balance (list (trans 'deposit 100) (trans 'withdraw 80)) 0 0)
20
> (update-balance (list (trans 'deposit 10) (trans 'withdraw 80)) 0 0)
10
I tried to learn the code in cal-china.el in Emacs source code and found the following code:
;;;###holiday-autoload
(defun holiday-chinese-winter-solstice ()
"Date of Chinese winter solstice, if visible in calendar.
Returns (((MONTH DAY YEAR) TEXT)), where the date is Gregorian."
(when (memq displayed-month '(11 12 1)) ; is December visible?
(list (list (calendar-gregorian-from-absolute
(calendar-chinese-zodiac-sign-on-or-after
(calendar-absolute-from-gregorian
(list 12 15 (if (eq displayed-month 1)
(1- displayed-year)
displayed-year)))))
"Winter Solstice Festival"))))
This code is used to calculate the winter solstice. I also knew that these 24 solar terms are needed for calculating Chinese calendar. So I wonder how to calculate all the 24 solar terms in Lisp.
Thank you.
For anyone interested in Chinese calendar, please refer to this repo for details.
https://github.com/xwl/cal-china-x
The solar terms can be calculated with the following code after you install cal-china-x
;;;###autoload
(defun holiday-solar-term (solar-term str)
"A holiday(STR) on SOLAR-TERM day.
See `cal-china-x-solar-term-name' for a list of solar term names ."
(cal-china-x-sync-solar-term displayed-year)
(let ((terms cal-china-x-solar-term-alist)
i date)
(while terms
(setq i (car terms)
terms (cdr terms))
(when (string= (cdr i) solar-term)
(let ((m (caar i))
(y (cl-caddar i)))
;; displayed-year, displayed-month is accurate for the centered month
;; only. Cross year view: '(11 12 1), '(12 1 2)
(when (or (and (cal-china-x-cross-year-view-p)
(or (and (= displayed-month 12)
(= m 1)
(= y (1+ displayed-year)))
(and (= displayed-month 1)
(= m 12)
(= y (1- displayed-year)))))
(= y displayed-year))
(setq terms '()
date (car i))))))
(holiday-fixed (car date) (cadr date) str)))