Category : Miscellaneous Language Source Code
Archive   : MTD.ZIP
Filename : CAL.PAS

 
Output of file : CAL.PAS contained in archive : MTD.ZIP
(*
** File: cal.pas (WITH BUGS!)
** Purpose: Display 6-month calendars
** Author: (c) 1990 by Tom Swan.
*)

program cal;


uses crt, dos;


const


{ ---- Miscellaneous constants }

NULL = #0; { Null character }
BLANK = #32; { Blank character }
LOWEST_YEAR = 1980; { Lowest legal year }
HIGHEST_YEAR = 2099; { Highest legal year }


{ ---- Key constants returned by getKey function }

KEY_ENTER = #13; KEY_ESC = #27;
KEY_HOME = #140; KEY_LEFT = #144;
KEY_RIGHT = #146; KEY_PGUP = #142;
KEY_PGDN = #150; KEY_INS = #151;


{ ---- Set of months with 30 days (the 'hath 30' months) }

HATH_THIRTY : set of 1 .. 12 = [ 4, 6, 9, 11 ];


{ ---- Names of months as character strings }

MONTH_NAMES : array[ 1 .. 12 ] of string[ 9 ] =
( 'January', 'February', 'March', 'April',
'May', 'June', 'July', 'August', 'September',
'October', 'November', 'December' );


{ ---- Number of days to the first of each month. }

DAY_OF_YEAR : array[ 1 .. 12 ] of word =
( 0, 31, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334 );


{ ---- Names of week days as character strings. }

DAY_NAMES : array[ 0 .. 6 ] of string[ 9 ] =
( 'Sunday', 'Monday', 'Tuesday', 'Wednesday',
'Thursday', 'Friday', 'Saturday' );


var

today : dateTime; { Today's date }
targetdate : dateTime; { First month to display }
userQuits : Boolean; { TRUE to quit program }


{ ---- Return key press }

function getKey : char;
const
KEY_OFFSET = 69; { 128 + readKey value for F1 (59) }
begin
getKey := readKey;
if keypressed and ( getKey = NULL )
then getKey := chr( ord( readKey ) + KEY_OFFSET );
end; { getKey }


{ ---- Return TRUE if low <= n <= hi }

function inRange( n, low, hi : integer ) : Boolean;
begin
inRange := ( low <= n ) and ( n <= hi )
end; { inRange }


{ ---- Return TRUE if year is a leap year }

function leapYear( year : word ) : Boolean;
begin
if year mod $100 = 0
then leapYear := ( year mod 400 ) = 0
else leapYear := ( year mod 4 ) = 0
end; { leapYear }


{ ---- Return last day of month for year and month in date d }

function lastDay( d : dateTime ) : word;
begin
with d do
begin
if month in HATH_THIRTY
then lastDay := 30 else
if month <> 2 then lastDay := 31 else
if leapYear( year )
then lastDay := 29
else lastDay := 28
end { with }
end; { lastDay }


{ ---- Return true if date d is a legal (existing) date }

function legalDate( d : dateTime ) : Boolean;
begin
legalDate := FALSE; { Default value for early exits }
with d do
begin
if not inRange( month, 1, 12 )
then exit;
if not inRange( year, LOWEST_YEAR, HIGHEST_YEAR )
then exit;
legalDate := inRange( day, 1, lastDay( d ) )
end { with }
end; { legalDate }


{ ---- Return 0=sun, 1=mon, ..., 7=sat for date d. Assumes
that date is legal. }

function dayOfWeek( d : dateTime ) : word;
var
oldYear, oldMonth, oldDay, dow : word;
begin
getDate( oldYear, oldMonth, oldDay, dow );
with d do
begin
setDate( year, month, day );
getDate( year, month, day, dow )
end; { with }
setDate( oldYear, oldMonth, oldDay );
dayOfWeek := dow
end; { dayOfWeek }


{ ---- Get today's date }

procedure getToday( var today : dateTime );
var yy, mm, dd, dow : word;
begin
getDate( yy, mm, dd, dow );
with today do
begin
year := yy;
month := mm;
day := dd
end { with }
end; { getToday }


{ ---- Add one month to date d. Note: The day is not
changed, which could result in an illegal date if day > 28 }

procedure nextMonth( var d : dateTime );
begin
with d do
if month < 12
then
inc( month )
else
begin
month := 1;
inc( year )
end { else }
end; { nextMonth }


{ ---- Subtract one month from date d. Note: The day is not
changed, which could result in an illegal date if day > 28 }

procedure prevMonth( var d : dateTime );
begin
with d do
if month > 1
then
dec( month )
else
begin
month := 12;
dec( year )
end
end; { prevMonth }


{ ---- Show one calendar at x, y = top left corner }

procedure showCal( x, y : word; d : dateTime );
var
showDay, weekday : integer;
currentmonth : Boolean;

procedure showMonthHeader( x, y : word; d : dateTime );
var
doy : integer; { Day of year }
begin
lowvideo;
gotoxy( x, y );
with d do
begin
doy := DAY_OF_YEAR[ month ];
if leapYear( year ) and ( month >= 3 )
then inc( doy );
write( year, BLANK:13, doy:3 );
gotoxy( (x + 10) -
( length( month_names[ month ] ) div 2 ), y );
highvideo;
write( month_names[ month ] )
end; { with }
gotoxy( x, y + 1 );
write( '--------------------' ); { 20 dashes }
gotoxy( x, y + 2 );
write( ' S M T W T F S' );
end; { showMonthHeader }

begin
with d do
begin
day := 1;
currentmonth := ( year = today.year ) and
( month = today.month );
showMonthHeader( x, y, d );
y := y + 3;
weekday := dayOfWeek( d );
gotoxy( x + ( weekday * 3 ), y );
for showDay := 1 to lastDay( d ) do
begin
if currentmonth and ( showDay = today.day )
then highvideo
else lowvideo;
write( showDay:2, BLANK );
inc( weekday );
if weekday >= 7 then
begin
weekday := 0;
inc( y );
gotoxy( x, y )
end { if }
end { for }
end { with }
end; { showCal }


{ ---- Show calendars starting from date d (with day = 1) }

procedure showCals( d : dateTime );
const
XCAL = 5; { Top left x coordinate of first calendar }
YCAL = 3; { " " y " " " " }
var
i : integer;
begin
if not legalDate( d ) then d := today;
d.day := 1;
for i := 0 to 5 do
begin
showCal( XCAL + (i mod 3) * 25, YCAL + (i div 3) * 10, d );
nextMonth( d )
end { for }
end; { showCals }


{ ---- Prompt for year to display }

procedure getNewDate( var d : dateTime );
begin
gotoxy( 1, 23 );
clreol;
write( 'Year ? ' );
readln( d.year );
d.day := 1;
d.month := 1
end; { getNewDate }


{ ---- Initialize global variables }

procedure initialize;
begin
if lastmode <> mono
then textcolor( brown );
userQuits := FALSE;
getToday( today );
targetdate := today;
end; { initialize }


{ ----- Display instructions }

procedure instructions;
begin
gotoxy( 1, 23 );
textcolor( white );
lowVideo;
write( '>Esc|Enter-Quit, Home-Today,' );
write( ' Left|Right-month, PgUp|PgDn|Ins-year ' );
end; { instructions }


begin
initialize;
repeat
clrscr;
showCals( targetdate );
instructions;
with targetDate do
case getKey of
KEY_ESC, KEY_ENTER : userQuits := TRUE;
KEY_HOME : targetDate := today;
KEY_INS : getNewDate( targetDate );
KEY_PGUP : dec( year );
KEY_PGDN : inc( year );
KEY_LEFT : prevMonth( targetDate );
KEY_RIGHT : nextMonth( targetDate );
end; { case }
until userQuits;
gotoxy( 1, 24 )
end.


  3 Responses to “Category : Miscellaneous Language Source Code
Archive   : MTD.ZIP
Filename : CAL.PAS

  1. Very nice! Thank you for this wonderful archive. I wonder why I found it only now. Long live the BBS file archives!

  2. This is so awesome! 😀 I’d be cool if you could download an entire archive of this at once, though.

  3. But one thing that puzzles me is the “mtswslnkmcjklsdlsbdmMICROSOFT” string. There is an article about it here. It is definitely worth a read: http://www.os2museum.com/wp/mtswslnk/