Advertisement
Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- (define (exist? x ls)
- (cond ((null? ls) #f)
- ((= x (car ls)) #t)
- (else (exist? x (cdr ls)))))
- (define (is-leap-year? year)
- (cond ((and (= (remainder year 4) 0) (not (= (remainder year 100) 0))) #t)
- ((= (remainder year 400) 0) #t)
- (else #f)))
- (define (make-date day month year)
- (define (range a b)
- (if (> a b) '()
- (cons a (range (+ a 1) b))))
- (define (is-valid-month? month)
- (if (exist? month (range 1 12)) #t
- #f))
- (define (valid-day-for-month month year)
- (cond ((and (= month 2) (is-leap-year? year)) (range 1 29))
- ((= month 2) (range 1 28))
- ((exist? month '(1 3 5 7 8 10 12)) (range 1 31))
- (else (range 1 30))))
- (define (is-valid-day? day)
- (if (exist? day (valid-day-for-month month year)) #t
- #f))
- (define (helper day month year)
- (cond ((not (is-valid-day? day)) #f)
- ((not (is-valid-month? month)) #f)
- (else (list day month year))))
- (helper day month year))
- (define (date? ls)
- (if (equal? ls #f) #f
- #t))
- (define (date->string date)
- (let ((day-str (number->string (car date)))
- (month-str (number->string (cadr date)))
- (year-str (number->string (caddr date))))
- (string-append day-str "." month-str "." year-str)))
- (define (next-day date)
- (define (last-day? day month year)
- (cond ((and (exist? month '(1 3 5 7 8 10 12)) (= day 31)) #t)
- ((and (exist? month '(4 6 9 11)) (= day 30)) #t)
- ((and (= month 2) (is-leap-year? year) (= day 29)) #t)
- ((and (= month 2) (not (is-leap-year? year)) (= day 28)) #t)
- (else #f)))
- (define (last-month? month)
- (if (= month 12) #t
- #f))
- (define (helper day month year)
- (cond ((and (last-day? day month year) (last-month? month)) (list 1 1 (+ year 1)))
- ((last-day? day month year) (list 1 (+ month 1) year))
- (else (list (+ day 1) month year))))
- (helper (car date) (cadr date) (caddr date)))
- (define (date< date1 date2)
- (define (helper day1 month1 year1 day2 month2 year2)
- (cond ((< year1 year2) #t)
- ((and (< month1 month2) (not (> year1 year2))) #t)
- ((and (< day1 day2) (not (> year1 year2))) #t)
- (else #f)))
- (helper (car date1) (cadr date1) (caddr date1) (car date2) (cadr date2) (caddr date2)))
- (define (get-sunday day1 month1 year1)
- (define (num-for-month month lst)
- (cond ((= (- month 1) 0) (car lst))
- (else (num-for-month (- month 1) (cdr lst)))))
- (define (last-basic-year start current)
- (cond ((> start current) (- start 28))
- (else (last-basic-year (+ start 28) current))))
- (define (count-of-leap-years start current count)
- (cond ((> start current) (- count 1))
- (else (count-of-leap-years (+ start 4) current (+ count 1)))))
- (define (last-leap-year start current)
- (cond ((> start current) (- start 4))
- (else (last-leap-year (+ start 4) current))))
- (define (count-of-normal-years start current count)
- (cond ((> start current) (- count 1))
- (else (count-of-normal-years (+ start 1) current (+ count 1)))))
- (let ((L (count-of-leap-years (last-basic-year 1916 year1) year1 0))
- (N (count-of-normal-years (last-leap-year 1916 year1) year1 0)))
- (+ (- (* 2 L) N) (num-for-month month1 '(8 5 5 9 7 4 9 6 3 8 5 3)))))
- (define (difference sunday day)
- (cond ((> (- sunday day) 7) (difference (- sunday 7) day))
- ((< (- sunday day) 0) (difference (+ sunday 7) day))
- (else (- sunday day))))
- (define (num-day1 day sunday)
- (- 7 (difference sunday day)))
- (define (weekday date)
- (define (helper num-day)
- (cond ((= num-day 1) 'Monday)
- ((= num-day 2) 'Tuesday)
- ((= num-day 3) 'Wednesday)
- ((= num-day 4) 'Thursday)
- ((= num-day 5) 'Friday)
- ((= num-day 6) 'Saturday)
- (else 'Sunday)))
- (cond ((and (or (= (cadr date) 1) (= (cadr date) 2)) (is-leap-year? (caddr date))) (helper (num-day1 (car date) (+ (get-sunday (car date) (cadr date) (caddr date)) 1))))
- (else (helper (num-day1 (car date) (get-sunday (car date) (cadr date) (caddr date)))))))
- (define (next-weekday day-of-week date)
- (cond ((equal? (weekday (next-day date)) day-of-week) (next-day date))
- (else (next-weekday day-of-week (next-day date)))))
- (define (events-for-day date lst)
- (define (helper date lst res)
- (cond ((null? lst) res)
- ((equal? (car (car lst)) date) (helper date (cdr lst) (append res (list (cons date (cdr (car lst)))))))
- (else (helper date (cdr lst) res))))
- (helper date lst '()))
- (define (keys alist) (map car alist))
- (define (values1 alist) (map cdr alist))
- (define (get-repeated list-of-events)
- (let ((key (car (car list-of-events))))
- (define (helper key lst res)
- (cond ((null? lst) (list res))
- ((equal? key (car (car lst))) (helper key (cdr lst) (append res (list (cdr (car lst))))))
- (else (helper key (cdr lst) res))))
- (helper key list-of-events (list key))))
- (define (get-all list-of-events)
- (define (helper lst res)
- (cond ((null? lst) res)
- (else (helper (cdr lst) (append res (get-repeated lst))))))
- (helper list-of-events '()))
- (define (delete-unwanted list-of-events list-for-deleting res)
- (let ((key (car (car list-of-events))))
- (cond ((null? (cdr list-of-events)) res)
- ((null? (cdr list-for-deleting)) (delete-unwanted (cdr list-of-events) (cdr (cdr list-of-events)) res))
- ((not (equal? key (car list-for-deleting))) (delete-unwanted list-of-events (cdr list-for-deleting) (list list-of-events)))
- (else (delete-unwanted list-of-events (cdr list-for-deleting) res)))))
- (define l (get-all (list (cons (make-date 27 11 2019) "Първа лекция за Хаскел")
- (cons (make-date 25 12 2019) "Коледа")
- (cons (make-date 27 11 2019) "Спират водата в Младост")
- (cons (make-date 23 3 2018) "Концерт на Лепа Брена"))))
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement