Advertisement
Guest User

Untitled

a guest
Dec 10th, 2019
201
0
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
Scheme 6.07 KB | None | 0 0
  1. (define (exist? x ls)
  2.     (cond ((null? ls) #f)
  3.           ((= x (car ls)) #t)
  4.           (else (exist? x (cdr ls)))))
  5.  
  6. (define (is-leap-year? year)
  7.     (cond ((and (= (remainder year 4) 0) (not (= (remainder year 100) 0))) #t)
  8.           ((= (remainder year 400) 0) #t)
  9.           (else #f)))
  10.  
  11. (define (make-date day month year)
  12.   (define (range a b)
  13.     (if (> a b) '()
  14.         (cons a (range (+ a 1) b))))
  15.   (define (is-valid-month? month)
  16.     (if (exist? month (range 1 12)) #t
  17.         #f))
  18.   (define (valid-day-for-month month year)
  19.     (cond ((and (= month 2) (is-leap-year? year)) (range 1 29))
  20.           ((= month 2) (range 1 28))
  21.           ((exist? month '(1 3 5 7 8 10 12)) (range 1 31))
  22.           (else (range 1 30))))
  23.   (define (is-valid-day? day)
  24.     (if (exist? day (valid-day-for-month month year)) #t
  25.         #f))
  26.   (define (helper day month year)
  27.     (cond ((not (is-valid-day? day)) #f)
  28.           ((not (is-valid-month? month)) #f)
  29.           (else (list day month year))))
  30.   (helper day month year))
  31.  
  32.  
  33. (define (date? ls)
  34.   (if (equal? ls #f) #f
  35.       #t))
  36.  
  37. (define (date->string date)
  38.   (let ((day-str (number->string (car date)))
  39.         (month-str (number->string (cadr date)))
  40.         (year-str (number->string (caddr date))))
  41.     (string-append day-str "." month-str "." year-str)))
  42.  
  43. (define (next-day date)
  44.   (define (last-day? day month year)
  45.     (cond ((and (exist? month '(1 3 5 7 8 10 12)) (= day 31)) #t)
  46.           ((and (exist? month '(4 6 9 11)) (= day 30)) #t)
  47.           ((and (= month 2) (is-leap-year? year) (= day 29)) #t)
  48.           ((and (= month 2) (not (is-leap-year? year)) (= day 28)) #t)
  49.           (else #f)))
  50.   (define (last-month? month)
  51.     (if (= month 12) #t
  52.         #f))
  53.   (define (helper day month year)
  54.     (cond ((and (last-day? day month year) (last-month? month)) (list 1 1 (+ year 1)))
  55.           ((last-day? day month year) (list 1 (+ month 1) year))
  56.           (else (list (+ day 1) month year))))
  57.   (helper (car date) (cadr date) (caddr date)))
  58.  
  59. (define (date< date1 date2)
  60.   (define (helper day1 month1 year1 day2 month2 year2)
  61.     (cond ((< year1 year2) #t)
  62.           ((and (< month1 month2) (not (> year1 year2))) #t)
  63.           ((and (< day1 day2) (not (> year1 year2))) #t)
  64.           (else #f)))
  65.   (helper (car date1) (cadr date1) (caddr date1) (car date2) (cadr date2) (caddr date2)))
  66.  
  67. (define (get-sunday day1 month1 year1)
  68.   (define (num-for-month month lst)
  69.     (cond ((= (- month 1) 0) (car lst))
  70.           (else (num-for-month (- month 1) (cdr lst)))))
  71.  
  72.   (define (last-basic-year start current)
  73.     (cond ((> start current) (- start 28))
  74.           (else (last-basic-year (+ start 28) current))))
  75.  
  76.   (define (count-of-leap-years start current count)
  77.     (cond ((> start current) (- count 1))
  78.           (else (count-of-leap-years (+ start 4) current (+ count 1)))))
  79.  
  80.   (define (last-leap-year start current)
  81.     (cond ((> start current) (- start 4))
  82.           (else (last-leap-year (+ start 4) current))))
  83.  
  84.   (define (count-of-normal-years start current count)
  85.     (cond ((> start current) (- count 1))
  86.           (else (count-of-normal-years (+ start 1) current (+ count 1)))))
  87.  
  88.   (let ((L (count-of-leap-years (last-basic-year 1916 year1) year1 0))
  89.         (N (count-of-normal-years (last-leap-year 1916 year1) year1 0)))
  90.     (+ (- (* 2 L) N) (num-for-month month1 '(8 5 5 9 7 4 9 6 3 8 5 3)))))
  91.  
  92.  
  93. (define (difference sunday day)
  94.   (cond ((> (- sunday day) 7) (difference (- sunday 7) day))
  95.         ((< (- sunday day) 0) (difference (+ sunday 7) day))
  96.         (else (- sunday day))))
  97.  
  98. (define (num-day1 day sunday)
  99.   (- 7 (difference sunday day)))
  100.  
  101. (define (weekday date)
  102.   (define (helper num-day)
  103.     (cond ((= num-day 1) 'Monday)
  104.           ((= num-day 2) 'Tuesday)
  105.           ((= num-day 3) 'Wednesday)
  106.           ((= num-day 4) 'Thursday)
  107.           ((= num-day 5) 'Friday)
  108.           ((= num-day 6) 'Saturday)
  109.           (else 'Sunday)))
  110.   (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))))
  111.         (else (helper (num-day1 (car date) (get-sunday (car date) (cadr date) (caddr date)))))))
  112.  
  113. (define (next-weekday day-of-week date)
  114.   (cond ((equal? (weekday (next-day date)) day-of-week) (next-day date))
  115.         (else (next-weekday day-of-week (next-day date)))))
  116.  
  117. (define (events-for-day date lst)
  118.   (define (helper date lst res)
  119.     (cond ((null? lst) res)
  120.           ((equal? (car (car lst)) date) (helper date (cdr lst) (append res (list (cons date (cdr (car lst)))))))
  121.           (else (helper date (cdr lst) res))))
  122.   (helper date lst '()))
  123.  
  124. (define (keys alist) (map car alist))
  125. (define (values1 alist) (map cdr alist))
  126.  
  127. (define (get-repeated list-of-events)
  128.   (let ((key (car (car list-of-events))))
  129.     (define (helper key lst res)
  130.       (cond ((null? lst) (list res))
  131.             ((equal? key (car (car lst))) (helper key (cdr lst) (append res (list (cdr (car lst))))))
  132.             (else (helper key (cdr lst) res))))
  133.     (helper key list-of-events (list key))))
  134.  
  135. (define (get-all list-of-events)
  136.   (define (helper lst res)
  137.     (cond ((null? lst) res)
  138.           (else (helper (cdr lst) (append res (get-repeated lst))))))
  139.   (helper list-of-events '()))
  140.  
  141. (define (delete-unwanted list-of-events list-for-deleting res)
  142.   (let ((key (car (car list-of-events))))
  143.     (cond ((null? (cdr list-of-events)) res)
  144.           ((null? (cdr list-for-deleting)) (delete-unwanted (cdr list-of-events) (cdr (cdr list-of-events)) res))
  145.           ((not (equal? key (car list-for-deleting))) (delete-unwanted list-of-events (cdr list-for-deleting) (list list-of-events)))
  146.           (else (delete-unwanted list-of-events (cdr list-for-deleting) res)))))
  147.  
  148. (define l (get-all (list (cons (make-date 27 11 2019) "Първа лекция за Хаскел")
  149.                 (cons (make-date 25 12 2019) "Коледа")
  150.                 (cons (make-date 27 11 2019) "Спират водата в Младост")
  151.                 (cons (make-date 23 3 2018) "Концерт на Лепа Брена"))))
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement