--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/calendar.ur	Fri Aug 05 18:55:24 2011 -0430
@@ -0,0 +1,220 @@
+style calendar
+style prev
+style this
+style next
+style weekday
+style curday
+style otherday
+style selday
+
+datatype month = Prev | This | Next
+
+type date = {Year : int, Month : int, Day : int}
+val date_eq = mkEq (fn {Year = y, Month = m, Day = d} {Year = y', Month = m', Day = d'} =>
+                       y = y' && m = m' && d = d')
+val date_ord = mkOrd {Lt = fn {Year = y1, Month = m1, Day = d1} {Year = y2, Month = m2, Day = d2} =>
+                              y1 < y2 || (y1 = y2 && m1 < m2) || (y1 = y2 && m1 = m2 && d1 < d2),
+                      Le = fn {Year = y1, Month = m1, Day = d1} {Year = y2, Month = m2, Day = d2} =>
+                              y1 < y2 || (y1 = y2 && m1 < m2) || (y1 = y2 && m1 = m2 && d1 <= d2)}
+
+type t = {Month : source {ThisMonth : int, Year : int,
+                          ThisMonthLength : int, PrevMonthLength : int,
+                          MondayMonth : month, MondayDay : int,
+                          PrevMonthName : string, ThisMonthName : string, NextMonthName : string},
+          Day : ChangePoller.changePoller date}
+         
+fun pad len n =
+    let
+        val s = show n
+
+        fun pad' len s =
+            if len <= 0 then
+                s
+            else
+                pad' (len-1) ("0" ^ s)
+    in
+        pad' (len - String.length s) s
+    end
+
+fun time {Year = y, Month = m, Day = d} = readError (show y ^ "-" ^ pad 2 m ^ "-" ^ pad 2 d ^ " 00:00:00")
+fun date tm =
+    let
+        val y = readError (timef "%Y" tm)
+        val m = readError (timef "%m" tm)
+        val d = readError (timef "%d" tm)
+    in
+        {Year = y, Month = m, Day = d}
+    end
+
+fun monthLen m =
+    let
+        fun f n tm =
+            let
+                val next = addSeconds tm (60 * 60 * 24)
+                val nextMon = readError (timef "%m" next)
+            in
+                if nextMon = m.Month then
+                    f (n+1) next
+                else
+                    n
+            end
+    in
+        f 28 (readError (show m.Year ^ "-" ^ pad 2 m.Month ^ "-28 00:00:00"))
+    end
+
+fun weekdayToNum s =
+    case s of
+        "Mon" => 0
+      | "Tue" => 1
+      | "Wed" => 2
+      | "Thu" => 3
+      | "Fri" => 4
+      | "Sat" => 5
+      | "Sun" => 6
+      | _ => error <xml>Datebox: Bad weekday name</xml>
+
+fun timeOfMonth my =
+    readError (show my.Year ^ "-" ^ pad 2 my.Month ^ "-01 00:00:00")
+
+fun monthInfo' this =
+    let
+        val prev = if this.Month = 1 then
+                       {Month = 12, Year = this.Year - 1}
+                   else
+                       {Month = this.Month-1, Year = this.Year}
+        val prevLen = monthLen prev
+
+        val next = if this.Month = 12 then
+                       {Month = 1, Year = this.Year + 1}
+                   else
+                       {Month = this.Month + 1, Year = this.Year}
+
+        val firstDow = weekdayToNum (timef "%a" (timeOfMonth this))
+    in
+        {ThisMonth = this.Month, Year = this.Year,
+         ThisMonthLength = monthLen this,
+         PrevMonthLength = prevLen,
+         MondayMonth = if firstDow = 0 then This else Prev,
+         MondayDay = if firstDow = 0 then 1 else prevLen - (firstDow - 1),
+         PrevMonthName = timef "%b" (timeOfMonth prev),
+         ThisMonthName = timef "%b" (timeOfMonth this),
+         NextMonthName = timef "%b" (timeOfMonth next)}
+    end
+
+fun monthInfo this = return (monthInfo' this)
+
+fun create tm =
+    year <- return (readError (timef "%Y" tm));
+    month <- return (readError (timef "%m" tm));
+    minf <- source (monthInfo' {Month = month, Year = year});
+    day <- return (readError (timef "%d" tm));
+    day <- ChangePoller.create {Year = year, Month = month, Day = day};
+    return {Month = minf, Day = day}
+
+fun render' t =
+    minf <- signal t.Month;
+    let
+        fun rows year month day =
+            let
+                fun row year month day weekday =
+                    if weekday >= 7 then
+                        <xml/>
+                    else
+                        <xml>
+                          <dyn signal={let
+                                           val thisDate = {Year = year,
+                                                           Month = case month of
+                                                                       Prev => if minf.ThisMonth = 1 then 12 else minf.ThisMonth - 1
+                                                                     | This => minf.ThisMonth
+                                                                     | Next => if minf.ThisMonth = 12 then 1 else minf.ThisMonth + 1,
+                                                           Day = day}
+                                       in
+                                           cday <- ChangePoller.value t.Day;
+                                           return (if Record.equal thisDate cday then
+                                                       <xml><td class={selday}>{[day]}</td></xml>
+                                                   else case month of
+                                                            This => <xml><td class={curday}
+                                                                             onclick={set (ChangePoller.ctl t.Day) thisDate}>{[day]}</td></xml>
+                                                          | _ => <xml><td class={otherday}>{[day]}</td></xml>)
+                                       end}/>
+                            {let
+                                 val (year, month, day) =
+                                     case month of
+                                         Prev => if day = minf.PrevMonthLength then
+                                                     (if minf.ThisMonth = 1 then year + 1 else year, This, 1)
+                                                 else
+                                                     (year, Prev, day+1)
+                                       | This => if day = minf.ThisMonthLength then
+                                                     (if minf.ThisMonth = 12 then year + 1 else year, Next, 1)
+                                                 else
+                                                     (year, This, day+1)
+                                       | Next => (year, Next, day+1)
+                             in
+                                 row year month day (weekday+1)
+                             end}
+                          </xml>
+            in
+                case month of
+                    Next => <xml/>
+                  | _ =>
+                    <xml>
+                      <tr>{row year month day 0}</tr>
+                      {let
+                           val next =
+                               case month of
+                                   Prev => Some (if minf.ThisMonth = 1 then year + 1 else year, This, day + 7 - minf.PrevMonthLength)
+                                 | This =>
+                                   Some (if day + 7 > minf.ThisMonthLength then
+                                             (if minf.ThisMonth = 12 then year + 1 else year, Next, day + 7 - minf.ThisMonthLength)
+                                         else
+                                             (year, This, day + 7))
+                                 | Next => None
+                       in
+                           case next of
+                               None => <xml/>
+                             | Some (year, month, day) => rows year month day
+                       end}
+                    </xml>
+            end
+    in
+        return <xml>
+          <table class={calendar}>
+            <tr>
+              <th class={prev} colspan={2}
+                  onclick={minf <- rpc (monthInfo (if minf.ThisMonth = 1 then
+                                                       {Month = 12, Year = minf.Year - 1}
+                                                   else
+                                                       {Month = minf.ThisMonth - 1, Year = minf.Year}));
+                           set t.Month minf}>&lt;&lt; {[minf.PrevMonthName]}</th>
+                  <th class={this} colspan={3}>{[minf.ThisMonthName]} {[minf.Year]}</th>
+                  <th class={next} colspan={2}
+                      onclick={minf <- rpc (monthInfo (if minf.ThisMonth = 12 then
+                                                           {Month = 1, Year = minf.Year + 1}
+                                                       else
+                                                           {Month = minf.ThisMonth + 1, Year = minf.Year}));
+                               set t.Month minf}>{[minf.NextMonthName]} >></th>
+            </tr>
+            <tr class={weekday}> <th>M</th> <th>Tu</th> <th>W</th> <th>Th</th> <th>F</th> <th>Sa</th> <th>Su</th> </tr>
+            {rows (if minf.ThisMonth = 1 && (case minf.MondayMonth of This => False | _ => True) then
+                       minf.Year - 1
+                   else
+                       minf.Year) minf.MondayMonth minf.MondayDay}
+          </table>
+        </xml>
+    end
+
+fun addListener f ctl =
+    ChangePoller.addChangeListener f 100 ctl.Day
+
+val gui_t = Gui.mkGui 
+                (fn ctl =>
+                    <xml>
+                      <dyn signal={render' ctl}/>
+                    </xml>)
+
+fun set ctl day =
+    minf <- rpc (monthInfo (day -- #Day));
+    Basis.set ctl.Month minf;
+    Basis.set (ChangePoller.ctl ctl.Day) day
+
+fun value ctl = ChangePoller.value ctl.Day