Partial implementation.

takagi · Sep 12, 2015 · 34ded62 · 34ded62
1 parent 11717af
commit 34ded62
Show file tree

Hide file tree

Showing 3 changed files with 151 additions and 51 deletions.
diff --git a/README.md b/README.md
@@ -69,13 +69,17 @@ Calendar-date is a Gregorian calendar date library in Common Lisp.
 
     PREVIOUS-WEEK calendar-date => new-calendar-date
 
-### [Function] beginning-of-next-week
+### [Function] same-day-of-next-week
 
-    BEGINNING-OF-NEXT-WEEK calendar-date => new-calendar-date
+    SAME-DAY-OF-NEXT-WEEK calendar-date => new-calendar-date
 
-### [Function] day-of-the-week
+### [Function] same-day-of-previous-week
 
-    DAY-OF-THE-WEEK day-of-week calendar-date => new-calendar-date
+    SAME-DAY-OF-PREVIOUS-WEEK calendar-date => new-calendar-date
+
+### [Function] day-of-week-of-the-week
+
+    DAY-OF-WEEK-OF-THE-WEEK day-of-week calendar-date => new-calendar-date
 
 ### [Function] next-month
 
@@ -85,22 +89,22 @@ Calendar-date is a Gregorian calendar date library in Common Lisp.
 
     PREVIOUS-MONTH calendar-date => new-calendar-date
 
-### [Function] first-of-the-month
-
-    FIRST-OF-THE-MONTH calendar-date => new-calendar-date
-
-### [Function] first-of-next-month
+### [Function] same-day-of-next-month
 
-    FIRST-OF-NEXT-MONTH calendar-date => new-calendar-date
+    SAME-DAY-OF-NEXT-MONTH calendar-date => new-calendar-date
 
-### [Function] first-of-previous-month
+### [Function] same-day-of-previous-month
 
-    FIRST-OF-PREVIOUS-MONTH calendar-date => new-calendar-date
+    SAME-DAY-OF-PREVIOUS-MONTH calendar-date => new-calendar-date
 
 ### [Function] nth-of-the-month
 
     NTH-OF-THE-MONTH nth calendar-date => new-calendar-date
 
+### [Function] first-of-the-month
+
+    FIRST-OF-THE-MONTH calendar-date => new-calendar-date
+
 ### [Function] nth-of-the-month-in-business
 
     NTH-OF-THE-MONTH-IN-BUSINESS nth calendar-date => new-calendar-date

diff --git a/src/calendar-date.lisp b/src/calendar-date.lisp
@@ -17,12 +17,14 @@
            :previous-week
            :next-month
            :previous-month
+           :same-day-of-next-month
+           :same-day-of-previous-month
            :first-of-the-month
-           :first-of-next-month
-           :first-of-previous-month
            :nth-of-the-month
            :nth-of-the-month-in-business
-           :last-day-of-the-month))
+           :nth-business-day-of-the-month
+           :last-day-of-the-month
+           :last-business-day-of-the-month))
 (in-package :calendar-date)
 
 
@@ -75,7 +77,8 @@
   (%make-calendar-date :year year :month month :day day))
 
 (defun calendar-date-day-of-week (calendar-date)
-  nil)
+  (multiple-value-bind (year month day) (calendar-date-values calendar-date)
+    (day-of-week year month day)))
 
 (defun calendar-date-values (calendar-date)
   (values (calendar-date-year calendar-date)
@@ -141,37 +144,34 @@
   calendar-date)
 
 (defun next-month (calendar-date)
+  (next-day
+   (last-day-of-the-month calendar-date)))
+
+(defun previous-month (calendar-date)
+  (first-of-the-month
+   (previous-day
+    (first-of-the-month calendar-date))))
+
+(defun same-day-of-next-month (calendar-date)
   (let ((day (calendar-date-day calendar-date)))
-    (let ((calendar-date1 (first-of-next-month calendar-date)))
+    (let ((calendar-date1 (next-month calendar-date)))
       (multiple-value-bind (year1 month1 day1)
           (calendar-date-values calendar-date1)
         (declare (ignore day1))
         (let ((nth (min day (last-day-of-year-month year1 month1))))
           (nth-of-the-month nth calendar-date1))))))
 
-(defun previous-month (calendar-date)
+(defun same-day-of-previous-month (calendar-date)
   (let ((day (calendar-date-day calendar-date)))
-    (let ((calendar-date1 (first-of-previous-month calendar-date)))
+    (let ((calendar-date1 (previous-month calendar-date)))
       (multiple-value-bind (year1 month1 day1)
           (calendar-date-values calendar-date1)
         (declare (ignore day1))
         (let ((nth (min day (last-day-of-year-month year1 month1))))
           (nth-of-the-month nth calendar-date1))))))
 
 (defun first-of-the-month (calendar-date)
-  (multiple-value-bind (year month day)
-      (calendar-date-values calendar-date)
-    (declare (ignore day))
-    (calendar-date year month 1)))
-
-(defun first-of-next-month (calendar-date)
-  (next-day
-   (last-day-of-the-month calendar-date)))
-
-(defun first-of-previous-month (calendar-date)
-  (first-of-the-month
-   (previous-day
-    (first-of-the-month calendar-date))))
+  (nth-of-the-month 1 calendar-date))
 
 (defun nth-of-the-month (nth calendar-date)
   (check-type nth (integer 1 31))
@@ -190,8 +190,32 @@
        do (setf calendar-date1 (previous-day calendar-date1)))
     calendar-date1))
 
+(defun nth-business-day-of-the-month (nth calendar-date)
+  (check-type nth (integer 1))
+  (let ((month (calendar-date-month calendar-date)))
+    (let ((calendar-date1 (first-of-the-month calendar-date)))
+      (loop
+         do ;; Decrement counter if business day.
+            (when (business-day-p calendar-date1)
+              (decf nth))
+            ;; Return the calendar date if counter reachs zero.
+            (when (= nth 0)
+              (return calendar-date1))
+            ;; Proceeds the calendar date.
+            (setf calendar-date1 (next-day calendar-date1))
+            ;; Error if steps into the next month.
+            (let ((month1 (calendar-date-month calendar-date1)))
+              (unless (= month month1)
+                (error "The value ~S is invalid." nth)))))))
+
 (defun last-day-of-the-month (calendar-date)
   (multiple-value-bind (year month day) (calendar-date-values calendar-date)
     (declare (ignore day))
     (let ((day1 (last-day-of-year-month year month)))
       (calendar-date year month day1))))
+
+(defun last-business-day-of-the-month (calendar-date)
+  (let ((calendar-date1 (last-day-of-the-month calendar-date)))
+    (loop until (business-day-p calendar-date1)
+       do (setf calendar-date1 (previous-day calendar-date1)))
+    calendar-date1))
diff --git a/t/calendar-date.lisp b/t/calendar-date.lisp
@@ -242,18 +242,23 @@
 (subtest "previous-week"
   )
 
+(subtest "same-day-of-next-week"
+  )
+
+(subtest "same-day-of-previous-week"
+  )
+
+(subtest "day-of-week-of-the-week"
+  )
+
 (subtest "next-month"
 
   (is (next-month (calendar-date 2015 1 1))
       (calendar-date 2015 2 1)
       :test #'calendar-date=)
 
-  (is (next-month (calendar-date 2015 1 31))
-      (calendar-date 2015 2 28)
-      :test #'calendar-date=)
-
-  (is (next-month (calendar-date 2016 1 31))
-      (calendar-date 2016 2 29)
+  (is (next-month (calendar-date 2015 1 2))
+      (calendar-date 2015 2 1)
       :test #'calendar-date=)
 
   (is-error (next-month :foo)
@@ -266,41 +271,68 @@
       (calendar-date 2015 1 1)
       :test #'calendar-date=)
 
-  (is (previous-month (calendar-date 2015 3 31))
+  (is (previous-month (calendar-date 2015 2 2))
+      (calendar-date 2015 1 1)
+      :test #'calendar-date=)
+
+  (is-error (previous-month :foo)
+            type-error
+            "invalid calendar date."))
+
+(subtest "same-day-of-next-month"
+
+  (is (same-day-of-next-month (calendar-date 2015 1 1))
+      (calendar-date 2015 2 1)
+      :test #'calendar-date=)
+
+  (is (same-day-of-next-month (calendar-date 2015 1 2))
+      (calendar-date 2015 2 2)
+      :test #'calendar-date=)
+
+  (is (same-day-of-next-month (calendar-date 2015 1 31))
       (calendar-date 2015 2 28)
       :test #'calendar-date=)
 
-  (is (previous-month (calendar-date 2016 3 31))
+  (is (same-day-of-next-month (calendar-date 2016 1 31))
       (calendar-date 2016 2 29)
       :test #'calendar-date=)
 
-  (is-error (previous-month :foo)
+  (is-error (same-day-of-next-month :foo)
             type-error
             "invalid calendar date."))
 
-(subtest "first-of-the-month"
+(subtest "same-day-of-previous-month"
 
-  (is (first-of-the-month (calendar-date 2015 1 1))
+  (is (same-day-of-previous-month (calendar-date 2015 2 1))
       (calendar-date 2015 1 1)
       :test #'calendar-date=)
 
-  (is-error (first-of-the-month :foo)
+  (is (same-day-of-previous-month (calendar-date 2015 2 2))
+      (calendar-date 2015 1 2)
+      :test #'calendar-date=)
+
+  (is (same-day-of-previous-month (calendar-date 2015 3 31))
+      (calendar-date 2015 2 28)
+      :test #'calendar-date=)
+
+  (is (same-day-of-previous-month (calendar-date 2016 3 31))
+      (calendar-date 2016 2 29)
+      :test #'calendar-date=)
+
+  (is-error (same-day-of-previous-month :foo)
             type-error
             "invalid calendar date."))
 
-(subtest "first-of-next-month"
+(subtest "first-of-the-month"
 
-  (is (first-of-next-month (calendar-date 2015 1 1))
-      (calendar-date 2015 2 1)
+  (is (first-of-the-month (calendar-date 2015 1 2))
+      (calendar-date 2015 1 1)
       :test #'calendar-date=)
 
-  (is-error (first-of-next-month :foo)
+  (is-error (first-of-the-month :foo)
             type-error
             "invalid calendar date."))
 
-(subtest "first-of-previous-month"
-  )
-
 (subtest "nth-of-the-month"
 
   (is (nth-of-the-month 1 (calendar-date 2015 1 1))
@@ -353,6 +385,36 @@
       (calendar-date 2015 1 2)
       :test #'calendar-date=))
 
+(subtest "nth-business-day-of-the-month"
+
+  (is (nth-business-day-of-the-month 1 (calendar-date 2015 1 1))
+      (calendar-date 2015 1 1)
+      :test #'calendar-date=)
+
+  (is (nth-business-day-of-the-month 3 (calendar-date 2015 1 1))
+      (calendar-date 2015 1 5)
+      :test #'calendar-date=)
+
+  (is (nth-business-day-of-the-month 22 (calendar-date 2015 1 1))
+      (calendar-date 2015 1 30)
+      :test #'calendar-date=)
+
+  (is-error (nth-business-day-of-the-month :foo (calendar-date 2015 1 1))
+            type-error
+            "invalid day.")
+
+  (is-error (nth-business-day-of-the-month 0 (calendar-date 2015 1 1))
+            type-error
+            "invalid day.")
+
+  (is-error (nth-business-day-of-the-month 23 (calendar-date 2015 1 1))
+            simple-error
+            "invalid day.")
+
+  (is-error (nth-business-day-of-the-month 1 :foo)
+            type-error
+            "invalid calendar date."))
+
 (subtest "last-day-of-the-month"
 
   (is (last-day-of-the-month (calendar-date 2015 1 1))
@@ -371,5 +433,15 @@
             type-error
             "invalid calendar date."))
 
+(subtest "last-business-day-of-the-month"
+
+  (is (last-business-day-of-the-month (calendar-date 2015 1 1))
+      (calendar-date 2015 1 30)
+      :test #'calendar-date=)
+
+  (is-error (last-business-day-of-the-month :foo)
+            type-error
+            "invalid calendar date."))
+
 
 (finalize)