home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / TURCAL.ZIP / TURBOCAL.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1988-08-20  |  18.4 KB  |  516 lines
  1.   {*********************************************************}
  2.   {*                     TurboCal 1.00                     *}
  3.   {*          Copyright (c) Kenny D. Walker 1988.          *}
  4.   {*                 All rights reserved.                  *}
  5.   {*********************************************************}
  6.  
  7.  
  8.   {*********************************************************}
  9.   {* You are free to use this software in other software   *}
  10.   {* programs for a one time registration fee of $10.00.   *}
  11.   {*                                                       *}
  12.   {* You are encouraged to distribute this software in     *}
  13.   {* UNMODIFIED form for others to use subject to the      *}
  14.   {* above registration.                                   *}
  15.   {*********************************************************}
  16.  
  17.   {*********************************************************}
  18.   {* If you have any suggestions or find any bugs, please  *}
  19.   {* contact the author on Compuserve, or my mail.         *}
  20.   {*                                                       *}
  21.   {*                   Kenny D. Walker                     *}
  22.   {*                   1819 Walthour Road                  *}
  23.   {*                   Savannah, Georgia, 31410            *}
  24.   {*                                                       *}
  25.   {*              Compuserve User ID: 70235,1160           *}
  26.   {*                                                       *}
  27.   {*********************************************************}
  28.  
  29.  
  30. unit turbocal;
  31.  
  32. interface
  33.  
  34. uses dos,tpcrt,tpstring;
  35.  
  36. procedure calendar(x,y,current_attr,select_attr,other_attr:byte;flag:boolean;var year,month,day:word);
  37.  
  38. implementation
  39. {$V-}
  40. const
  41.   intenseattr:byte=$0F;   {default attribute for days of current month}
  42.     reverseattr:byte=$70;   {default attribute for selected day}
  43.     normalattr:byte =$07;   {default attribute for days of non-current months}
  44.     blinkattr:byte  =$80;   {blink attribute, ORed with other attribute to
  45.                            cause blinking of current system date}
  46.  
  47.   NULL = #0;              {defines for ScanKey Function from MISCTOOL unit}
  48.   BELL = #7;              {MISCTOOL is a unit supplied in the Turbo Pascal}
  49.   BS = #8;                {Database Toolbox for TP4.  That software is NOT}
  50.   LF = #10;               {required for operation of this unit, the necessary}
  51.   CR = #13;               {code is included here}
  52.   ESC = #27;
  53.   Space = #32;
  54.   Tab = #9;
  55.  
  56.   { The following constants are based on the scheme used by the scan key
  57.     function to convert a two key scan code sequence into one character
  58.     by adding 128 to the ordinal value of the second character.
  59.   }
  60.   F1 = #187;
  61.   F2 = #188;
  62.   F3 = #189;
  63.   F4 = #190;
  64.   F5 = #191;
  65.   F6 = #192;
  66.   F7 = #193;
  67.   F8 = #194;
  68.   F9 = #195;
  69.   F10 = #196;
  70.   UpKey = #200;
  71.   DownKey = #208;
  72.   LeftKey = #203;
  73.   RightKey = #205;
  74.   PgUpKey = #201;
  75.   PgDnKey = #209;
  76.   HomeKey = #199;
  77.   EndKey = #207;
  78.   InsKey = #210;
  79.   DelKey = #211;
  80.   CopyRightKey = #255;
  81. type
  82.  
  83.   boxtype=array[1..242] of byte;     {this is an array type used to store
  84.                                       information about the month which is
  85.                                       being displayed}
  86.  
  87.   datetype=record                    {type used internally, corresponds with}
  88.     year,month,day,dayofweek:word;   {the values returned by the GetDate    }
  89.   end;                               {procedure in TP4}
  90.  
  91.  
  92. function ScanKey : char;
  93. { Reads a key from the keyboard and converts 2 scan code escape
  94.   sequences into 1 character. }
  95.  
  96. var
  97.   Ch : Char;
  98. begin
  99.   Ch := ReadKey;
  100.   if (Ch = #0) and KeyPressed then
  101.   begin
  102.     Ch := ReadKey;
  103.     if ord(Ch) < 128 then
  104.       Ch := Chr(Ord(Ch) + 128);
  105.   end;
  106.   ScanKey := Ch;
  107. end; { ScanKey }
  108.  
  109.   {*********************************************************}
  110.   {* The following two functions: leap_year and            *}
  111.   {* day_of_week are from the file EXDATE.PAS which is     *}
  112.   {* available in Data Library 2 of the Borland Turbo      *}
  113.   {* Pascal SIG on Compuserve.  These functions were       *}
  114.   {* authored by Ted Lassagne.                             *}
  115.   {*********************************************************}
  116.  
  117.  
  118. function leap_year(year: integer) : boolean;
  119.   { Returns true for a leap year and false for others }
  120. begin
  121.   if year and 3 <> 0 then leap_year := false
  122.   else if year mod 100 <> 0 then leap_year := true
  123.        else if year mod 400 <> 0 then leap_year := false
  124.             else leap_year := true;
  125. end;
  126.  
  127. function day_of_week (day, month, year: integer) : integer;
  128.   {Returns integer day of week for date.  0 = Sunday, 6 = Saturday
  129.    Uses Zeller's congruence.}
  130. var century, yr, dw: integer;
  131.  
  132. begin
  133.   if month < 3 then begin
  134.     month := month + 10;
  135.     year := year -1
  136.   end
  137.   else
  138.      month := month - 2;
  139.   century := year div 100;
  140.   yr := year mod 100;
  141.   dw := (((26*month - 2) div 10)+day+yr+(yr div 4)+
  142.                 (century div 4) - (2*century)) mod 7;
  143.   if dw < 0 then
  144.         day_of_week := dw + 7
  145.     else day_of_week := dw;
  146. end;
  147.  
  148.  
  149. function intstr(value: integer): string;
  150. {This function is merely a shell around the STR procedure, in order to
  151.  provided the result in function form}
  152. var
  153.   numstring : string;
  154.  
  155. begin
  156.   Str(Value,NumString);
  157.   IntStr := NumString;
  158. end;
  159.  
  160.  
  161. procedure calendar(x,y,current_attr,select_attr,other_attr:byte;flag:boolean;var year,month,day:word);
  162. const
  163.   dpm:array[0..11] of integer = (31,28,31,30,31,30,31,31,30,31,30,31);
  164.   names:array[0..11] of string[9] = ('January','February','March','April',
  165.                                                                          'May','June','July','August','September',
  166.                                                                          'October','November','December');
  167.  
  168.  
  169. var
  170.   tday,c,extra,mo,tyear:integer;
  171.   daystr:string[4];
  172.   ch:char;
  173.   color:byte;
  174.   yrstr:string[4];
  175.   todaysdate:datetype;    {internal storage of current system date}
  176.   date:datetype;          {internal useage of date passed in var parameters}
  177.   buffer:pointer;         {needed for use by savewindow and restorewindow}
  178.   calbox:boxtype;         {actual array variable used to store calendar. This
  179.                            array contains one byte for the character of the
  180.                            display and one byte for its attribute}
  181.  
  182.   calptr:pointer;         {pointer to location of calbox}
  183.  
  184. procedure stuffcal;
  185. {this is the procedure which actually places the calendar on the screen.  The
  186.  calendar is constructed in memory in its entirety and then placed on to the
  187.  screen with the restorewindow procedure.  This is actually a trick since the
  188.  calbox window was never saved.}
  189. var
  190.   count,s:integer;
  191.   limit:integer;
  192. begin
  193.   str(date.year,yrstr);              {make year string for display}
  194.   framewindow(x,y,x+21,y+8,7,7,'');  {draw frame around calendar window}
  195.  
  196.   {write name of month on top line of calendar window}
  197.   fastwrite(center(names[date.month-1]+' '+yrstr,20),y+1,x+1,reverseattr);
  198.  
  199.   {clear array each time}
  200.   for count:=1 to 242 do
  201.     if odd(count) then
  202.       calbox[count]:=32            {set character to 'space'}
  203.     else
  204.       calbox[count]:=normalattr;   {set attribute for character}
  205.  
  206.   count:=1;
  207.  
  208.   {get day of week for the month in question}
  209.   tday:=day_of_week(1,integer(date.month),integer(date.year));
  210.  
  211.   tyear:=date.year;
  212.   mo:=date.month-1;  {constant dpm and names arrays are zero based}
  213.  
  214.   color:=normalattr; {set attribute to low intensity for days of month
  215.                       which precede month to be displayed}
  216.   s:=0;
  217.   c:=0;
  218.  
  219.   {set up calendar for last days of previous month}
  220.   if(tday>0) then
  221.     for s:=0 to tday-1 do begin
  222.       if((mo-1=1) and (leap_year(date.year))) then  {if the last month was }
  223.         extra:=2                                    {February, check for   }
  224.       else                                          {leap year}
  225.         extra:=1;
  226.       if(mo=0) then
  227.         daystr:=intstr((dpm[mo]+s-tday+extra))      {make 2 character string}
  228.       else                                          {for number value of day}
  229.         daystr:=intstr((dpm[mo-1]+s-tday+extra));   {pad left with blank for}
  230.       daystr:=leftpad(daystr,2);                    {single digit days}
  231.  
  232.       calbox[count]:=ord(daystr[1]);                {for each day, place ord}
  233.       calbox[count+1]:=color;                       {value of string char in}
  234.       calbox[count+2]:=ord(daystr[2]);              {array, followed by attr}
  235.       calbox[count+3]:=color;                       {for that value.  Each  }
  236.       calbox[count+4]:=32;                          {day needs to be followed}
  237.       calbox[count+5]:=color;                       {by a space character for}
  238.       c:=c+1;                                       {separation from the next}
  239.       count:=count+6;                               {day                     }
  240.     end;
  241.  
  242.   tday:=1;
  243.   color:=intenseattr;    {change color to that for days of month to be
  244.                           displayed}
  245.  
  246.   while (tday<=dpm[mo]) do begin
  247.     daystr:=intstr(tday);
  248.     daystr:=leftpad(daystr,2);
  249.     if(tday=date.day) then begin
  250.       calbox[count]:=ord(daystr[1]);       {as above stuff array with values}
  251.       calbox[count+1]:=reverseattr;        {and attributes.  This section   }
  252.       calbox[count+2]:=ord(daystr[2]);     {tests to see if day being       }
  253.       calbox[count+3]:=reverseattr;        {stuffed is the current selection}
  254.       calbox[count+4]:=32;                 {day and if so, sets attribute to}
  255.       calbox[count+5]:=color;              {the attribute for selected day  }
  256.     end
  257.     else begin
  258.       calbox[count]:=ord(daystr[1]);       {if day being stuffed was NOT the}
  259.       calbox[count+1]:=color;              {selected day, then attribute is }
  260.       calbox[count+2]:=ord(daystr[2]);     {the attribute for days of current}
  261.       calbox[count+3]:=color;              {month}
  262.       calbox[count+4]:=32;
  263.       calbox[count+5]:=color;
  264.     end;
  265.     if((tday=todaysdate.day) and (mo=todaysdate.month-1) and
  266.              (tyear=todaysdate.year) and (flag)) then begin
  267.       calbox[count+1]:=(calbox[count+1] or blink);  {if the day being stuffed}
  268.       calbox[count+3]:=(calbox[count+3] or blink);  {is the current day as in}
  269.     end;                                            {system date cause to    }
  270.                                                     {blink                   }
  271.  
  272.     tday:=tday+1;
  273.     c:=c+1;
  274.     count:=count+6;
  275.     if(c>6) then begin
  276.       c:=0;
  277.       count:=count-2;
  278.     end;
  279.   end;
  280.  
  281.   {the following sections makes adjustments to February for leap year}
  282.   if((mo=1) and (leap_year(date.year))) then begin
  283.     daystr:=intstr(tday);
  284.     daystr:=leftpad(daystr,2);
  285.     c:=c+1;
  286.     calbox[count]:=ord(daystr[1]);
  287.     if(date.day<>29) then
  288.       calbox[count+1]:=color
  289.     else
  290.       calbox[count+1]:=reverseattr;
  291.     calbox[count+2]:=ord(daystr[2]);
  292.     if(date.day<>29) then
  293.       calbox[count+3]:=color
  294.     else
  295.       calbox[count+3]:=reverseattr;
  296.     calbox[count+4]:=32;
  297.     calbox[count+5]:=color;
  298.     count:=count+6;
  299.   end;
  300.  
  301.   color:=normalattr;     {set attribute back in order to display days of}
  302.   if(c>0) then           {month which follow the displayed month}
  303.     for s:=1 TO 7-c do begin
  304.       daystr:=intstr(s);
  305.       daystr:=leftpad(daystr,2);                 {stuff days as before}
  306.       calbox[count]:=ord(daystr[1]);
  307.       calbox[count+1]:=color;
  308.       calbox[count+2]:=ord(daystr[2]);
  309.       calbox[count+3]:=color;
  310.       calbox[count+4]:=32;
  311.       calbox[count+5]:=color;
  312.       count:=count+6;
  313.     end;
  314.  
  315.   calptr:=@calbox;  {set pointer to point to calendar array, this is the
  316.                      trick which allows restore window to restore a window
  317.                      which has never been saved}
  318.  
  319.   restorewindow(x+1,y+2,x+20,y+7,false,calptr);
  320. end;
  321.  
  322.  
  323. {this procedure is used to adjust the displayed month based upon the key
  324.  pressed while in the selection mode}
  325. procedure getcalkey(var date:datetype);
  326. var
  327.   chr1,chr2:char;
  328.   tempdate:datetype;
  329.   n:integer;
  330.   oldxy,scanlines:word;
  331. begin
  332.   getcursorstate(oldxy,scanlines);   {hide the cursor}
  333.     hiddencursor;
  334.   tempdate:=date;
  335.   repeat
  336.     date:=tempdate;
  337.         stuffcal;           {draw calendar}
  338.     chr1:=scankey;      {get keypress}
  339.     case chr1 of
  340.       CR:begin          {this accepts the date displayed}
  341.          end;
  342.       ESC:begin         {exit set date values to 0}
  343.             tempdate.year:=0;
  344.             tempdate.month:=0;
  345.             tempdate.day:=0;
  346.           end;
  347.       LeftKey:if tempdate.day>1 then               {decrement day value}
  348.                 tempdate.day:=tempdate.day-1
  349.               else
  350.               if tempdate.month>1 then begin
  351.                 tempdate.month:=tempdate.month-1;
  352.                 tempdate.day:=dpm[tempdate.month-1];
  353.                 if((tempdate.month=2) and (leap_year(tempdate.year))) then
  354.                   tempdate.day:=29;
  355.               end
  356.               else begin
  357.                 if(tempdate.year>1) then
  358.                                     tempdate.year:=tempdate.year-1;
  359.                 tempdate.month:=12;
  360.                 tempdate.day:=31;
  361.               end;
  362.       RightKey:if tempdate.day<dpm[tempdate.month-1] then {increment day value}
  363.                  tempdate.day:=tempdate.day+1
  364.                else
  365.                  if((tempdate.month=2) and (leap_year(tempdate.year))) then
  366.                if(tempdate.day<>29) then
  367.                  tempdate.day:=29
  368.                else begin
  369.                  tempdate.day:=1;
  370.                  tempdate.month:=tempdate.month+1;
  371.                end
  372.                else
  373.                  if tempdate.month<12 then begin
  374.                    tempdate.month:=tempdate.month+1;
  375.                    tempdate.day:=1;
  376.                  end
  377.                  else begin
  378.                    if(tempdate.year<65535) then
  379.                                          tempdate.year:=tempdate.year+1;
  380.                    tempdate.month:=1;
  381.                    tempdate.day:=1;
  382.                  end;
  383.       UpKey:if tempdate.month>1 then begin      {decrement month value}
  384.               tempdate.month:=tempdate.month-1;
  385.               if tempdate.day>dpm[tempdate.month-1] then
  386.                 tempdate.day:=dpm[tempdate.month-1];
  387.             end
  388.             else begin
  389.               tempdate.month:=12;
  390.               if(tempdate.year>1) then
  391.                                 tempdate.year:=tempdate.year-1;
  392.             end;
  393.       DownKey:if tempdate.month<12 then begin   {increment month value}
  394.                 tempdate.month:=tempdate.month+1;
  395.                 if tempdate.day>dpm[tempdate.month-1] then
  396.                   tempdate.day:=dpm[tempdate.month-1];
  397.               end
  398.               else begin
  399.                 if(tempdate.year<65535) then
  400.                                     tempdate.year:=tempdate.year+1;
  401.                 tempdate.month:=1;
  402.               end;
  403.       PgUpKey:begin                            {increment year value}
  404.                 if(tempdate.year>1) then begin
  405.                                     tempdate.year:=tempdate.year-1;
  406.                   if((tempdate.month=2) and (tempdate.day=29)) then
  407.                     tempdate.day:=28;
  408.                                 end;
  409.               end;
  410.       PgDnKey:begin                            {decrement year value}
  411.                 if(tempdate.year<65535) then begin
  412.                                     tempdate.year:=tempdate.year+1;
  413.                   if((tempdate.month=2) and (tempdate.day=29)) then
  414.                     tempdate.day:=28;
  415.                                 end;
  416.               end;
  417. {this following keypress value can be remove, but NOT altered, it diplays
  418.  a small copyright notice in the calendar window and pauses for a keypress}
  419.       CopyRightKey:begin
  420.                                  fastwrite(center('TurboCal',20),y+1,x+1,reverseattr);
  421.                                  fastwrite(center(' ',20),y+2,x+1,reverseattr);
  422.                                  fastwrite(center('(c) Copyright 1988',20),y+3,x+1,reverseattr);
  423.                                  fastwrite(center(' Kenny D. Walker',20),y+4,x+1,reverseattr);
  424.                                  fastwrite(center('All  Rights Reserved',20),y+5,x+1,reverseattr);
  425.                                  fastwrite(center(' ',20),y+6,x+1,reverseattr);
  426.                                  fastwrite(center('Press A Key',20),y+7,x+1,reverseattr);
  427.                                  chr1:=scankey;
  428.                                  chr1:='a';
  429.                                      end;
  430.       else
  431.           write(BELL);           {sound for invalid key press}
  432.     end;{case}
  433.   until chr1 in [CR,ESC];        {can only exit with these two key values}
  434.   date:=tempdate;
  435.     restorecursorstate(oldxy,scanlines);    {restore cursor}
  436. end;
  437.  
  438.  
  439. begin {calendar}
  440.   if(other_attr<>0) then                    {check attribute values}
  441.     normalattr:=other_attr;
  442.   if(current_attr<>0) then
  443.     intenseattr:=current_attr;
  444.   if(select_attr<>0) then
  445.     reverseattr:=select_attr;
  446.  
  447.   if(x<1) then                              {check display coordinates}
  448.     x:=1;
  449.   if(y<1) then
  450.     y:=1;
  451.   if(x>58) then
  452.     x:=58;
  453.   if(flag) then begin
  454.     if(y>8) then
  455.       y:=8;
  456.   end
  457.   else
  458.     if(y>16) then
  459.       y:=16;
  460.  
  461.   with todaysdate do
  462.     getdate(year,month,day,dayofweek);     {get current system date}
  463.  
  464.     if(not(month in [1..12])) then           {check VAR parameter values}
  465.         month:=1;
  466.     if(month=2) then begin
  467.         if(leap_year(year)) then begin
  468.             if(day>29) then
  469.                 day:=29;
  470.         end
  471.         else
  472.             if(day>28) then
  473.                 day:=28;
  474.     end
  475.     else
  476.         case month of
  477.             1,3,5,7,8,10,12:if(day>31) then
  478.                                                 day:=31;
  479.             2,4,6,8,11:if(day>30) then
  480.                                      day:=30;
  481.         end;
  482.     if(year<1) then
  483.         year:=1;
  484.     if(day<1) then
  485.         day:=1;
  486.  
  487.   date.year:=year;
  488.   date.month:=month;
  489.   date.day:=day;
  490.   if flag then begin                                   {if wanting to use}
  491.     if not savewindow(x,y,x+21,y+16,true,buffer) then; {selection mode, save}
  492.     framewindow(x,y+9,x+21,y+16,7,15,'Calendar Keys'); {current screen, and}
  493.     fastwrite('Prev  Next',y+10,x+9,7);                {draw instruction   }
  494.     fastwrite('Day    '+chr(27)+'      '+chr(26),y+11,x+3,7);  {screen}
  495.     fastwrite('Month  '+chr(24)+'      '+chr(25),y+12,x+3,7);
  496.     fastwrite('Year  PgUp  PgDn',y+13,x+3,7);
  497.     fastwrite(chr(17)+chr(196)+chr(217)+' Accept',y+14,x+6,7);
  498.     fastwrite('Esc Cancel',y+15,x+6,7);
  499.     changeattribute(8,y+11,x+10,15);
  500.     changeattribute(8,y+12,x+10,15);
  501.     changeattribute(10,y+13,x+9,15);
  502.     changeattribute(3,y+14,x+6,15);
  503.     changeattribute(3,y+15,x+6,15);
  504.     getcalkey(date);                                   {get the date}
  505.     restorewindow(x,y,x+21,y+16,true,buffer);          {restore screen}
  506.   end
  507.   else                     {if not using selection mode, then just draw}
  508.     stuffcal;              {calendar}
  509.  
  510.   year:=date.year;         {return selected date in VAR parameters}
  511.   month:=date.month;
  512.   day:=date.day;
  513. end;
  514.  
  515. begin
  516. end.