{ Calendar unit demo program }
{ Jeff Duntemann -- 2/3/89 }
PROGRAM CalTest;
USES DOS,Crt, { Standard Borland units }
Screens, { Given in DDJ 4/89 }
Calendar; { Given in DDJ 6/89 }
CONST
YellowOnBlue = $1E; { Text attribute; yellow chars on blue background }
CalX = 25;
CalY = 5;
VAR
MyScreen : ScreenPtr; { Type exported by Screens unit }
WorkScreen : Screen; { Type exported by Screens unit }
Ch : Char;
Quit : Boolean;
ShowFor : DateTime; { Type exported by DOS unit }
I : Word; { Dummy; picks up dayofweek field in GetDate }
BEGIN
MyScreen := @WorkScreen; { Create a pointer to WorkScreen }
InitScreen(MyScreen,True);
ClrScreen(MyScreen,ClearAtom); { Clear the entire screen }
Quit := False;
WITH ShowFor DO { Start with clock date }
GetDate(Year,Month,Day,I);
REPEAT { Until Enter is pressed: }
IF Keypressed THEN { If a keystroke is detected }
BEGIN
Ch := ReadKey; { Pick up the keystroke }
IF Ord(Ch) = 0 THEN { See if it's an extended keystroke }
BEGIN
Ch := ReadKey; { If so, pick up scan code }
CASE Ord(Ch) OF { and parse it }
72 : Pan(MyScreen,Up,1); { Up arrow }
80 : Pan(MyScreen,Down,1); { Down arrow }
75 : BEGIN { Left arrow; "down time" }
WITH ShowFor DO
IF Month = 1 THEN
BEGIN
Month := 12;
Dec(Year)
END
ELSE Dec(Month);
ShowCalendar(MyScreen,ShowFor,CalX,CalY,YellowOnBlue);
END;
77 : BEGIN { Right arrow; "up time" }
WITH ShowFor DO
IF Month = 12 THEN
BEGIN
Month := 1;
Inc(Year)
END
ELSE Inc(Month);
ShowCalendar(MyScreen,ShowFor,CalX,CalY,YellowOnBlue);
END;
END { CASE }
END
ELSE { If it's an ordinary keystroke, test for quit: }
IF Ch = Chr(13) THEN Quit := True
END;
UNTIL Quit;
ClrScreen(MyScreen,ClearAtom) { All this stuff's exported by Screens }
END.
[LISTING TWO]
{--------------------------------------------------------------}
{ CALENDAR }
{ }
{ Text calendar for virtual screen platform }
{ }
{ by Jeff Duntemann KI6RA }
{ Turbo Pascal 5.0 }
{ Last modified 2/3/89 }
{--------------------------------------------------------------}
UNIT Calendar;
INTERFACE
USES DOS, { Standard Borland unit }
TextInfo, { Given in DDJ 3/89 }
Screens, { Given in DDJ 4/89 }
CalCalc; { Given in DDJ 6/89 courtesy Michael Covington }
TYPE
DaysOfWeek = (Sunday,Monday,Tuesday,Wednesday,Thursday,Friday,Saturday);
Months = (January,February,March,April,May,June,July,
August,September,October,November,December);
BEGIN
{ DayInset allows is to specify which day of the week the first of the }
{ month falls. It's an offset into the block containing day figures }
DayInset := (7-Ord(StartDay))*4;
{ DayTopStop allows us to specify how many days to show in the month. }
DayTopStop := 28+(DayCount*4)-DayInset;
BlkBlast(Target,@CalFrame, { Display the calendar frame }
VisibleX,VisibleY, { Genned screen size from TextInfo unit }
CalX,CalY, { Show at specified coordinates }
29,17, { Size of calendar frame block }
Attribute, { Attribute to use for calendar frame }
0, { No interspersed empty lines }
0); { No topstop; show the whole thing. }
WITH FudgeIt DO { FudgeIt is a free union allowing pointer arithmetic }
BEGIN
APointer := @CalData; { Create the pointer to the days block }
OfsWord := OfsWord+DayInset; { Offset into block for start day }
BlkBlast(Target,APointer, { Blast the day block over the }
VisibleX,VisibleY, { calendar frame }
CalX+1,CalY+5, { Pos. of days relative to frame }
28,6, { Size of day block }
Attribute, { Show days in same color as frame }
1, { Insert 1 line between block lines }
DayTopStop) { Set limit on number of chars to }
END { be copied from block to control }
END; { how many days shown for a month }
BEGIN
{ First figure day number since 1980: }
WITH ShowFor DO TargetDay := DayNumber(Year,Month,1);
{ Then use the day number to calculate day-of-the-week: }
StartDay := DaysOfWeek(WeekDay(TargetDay)-1);
TargetMonth := Months(ShowFor.Month-1);
DaysInMonth := Days[TargetMonth];
{ Test and/or adjust for leap year: }
IF TargetMonth = February THEN
IF IsLeapYear(ShowFor.Year) THEN DaysInMonth := 29;
{ Now draw the frame on the virtual screen! }
FrameCalendar(Target,
CalX,CalY,
Attribute,
StartDay,
DaysInMonth);
{ Add the month name and year atop the frame: }
GotoXY(Target,CalX+NameOffset[TargetMonth],CalY+1);
WriteTo(Target,MonthNames[TargetMonth]+' '+IntStr(ShowFor.Year,4));
END;
END.
[LISTING THREE]
UNIT CalCalc;
{ --- Calendrics --- }
{ Long-range calendrical package in standard Pascal }
{ Copyright 1985 Michael A. Covington }
INTERFACE
function daynumber(year,month,day:integer):real;
procedure caldate(date:real; var year,month,day:integer);
function weekday(date:real):integer;
function julian(date:real):real;
IMPLEMENTATION
function floor(x:real) : real;
{ Largest whole number not greater than x. }
{ Uses real data type to accommodate large numbers. }
begin
if (x < 0) and (frac(x) <> 0) then
floor := int(x) - 1.0
else
floor := int(x)
end;
function daynumber(year,month,day:integer):real;
{ Number of days elapsed since 1980 January 0 (1979 December 31). }
{ Note that the year should be given as (e.g.) 1985, not just 85. }
{ Switches from Julian to Gregorian calendar on Oct. 15, 1582. }
var
y,m: integer;
a,b,d: real;
begin
if year < 0 then y := year + 1
else y := year;
m := month;
if month < 3 then
begin
m := m + 12;
y := y - 1
end;
d := floor(365.25*y) + int(30.6001*(m+1)) + day - 723244.0;
if d < -145068.0 then
{ Julian calendar }
daynumber := d
else
{ Gregorian calendar }
begin
a := floor(y/100.0);
b := 2 - a + floor(a/4.0);
daynumber := d + b
end
end;
procedure caldate(date:real; var year,month,day:integer);
{ Inverse of DAYNUMBER; given date, finds year, month, and day. }
{ Uses real arithmetic because numbers are too big for integers. }
var
a,aa,b,c,d,e,z: real;
y: integer;
begin
z := int(date + 2444239.0);
if date < -145078.0 then
{ Julian calendar }
a := z
else
{ Gregorian calendar }
begin
aa := floor((z-1867216.25)/36524.25);
a := z + 1 + aa - floor(aa/4.0)
end;
b := a + 1524.0;
c := int((b-122.1)/365.25);
d := int(365.25*c);
e := int((b-d)/30.6001);
day := trunc(b - d - int(30.6001*e));
if e > 13.5 then month := trunc(e - 13.0)
else month := trunc(e - 1.0);
if month > 2 then y := trunc(c - 4716.0)
else y := trunc(c - 4715.0);
if y < 1 then year := y - 1
else year := y
end;
function weekday(date:real):integer;
{ Given day number as used in the above routines, }
{ finds day of week (1 = Sunday, 2 = Monday, etc.). }
var
dd: real;
begin
dd := date;
while dd > 28000.0 do dd:=dd-28000.0;
while dd < 0 do dd:=dd+28000.0;
weekday := ((trunc(dd) + 1) mod 7) + 1
end;
function julian(date:real):real;
{ Converts result of DAYNUMBER into a Julian date. }
begin
julian := date + 2444238.5
end;
END. { CalCalc }
[LISTING FOUR]
;===========================================================================
;
; B L K B L A S T - Blast 2D character pattern and attributes into memory
;
;===========================================================================
;
; by Jeff Duntemann 3 February 1989
;
; BLKBLAST is written to be called from Turbo Pascal 5.0 using the EXTERNAL
; machine-code procedure convention.
;
; This version is written to be used with the SCREENS.PAS virtual screens
; unit for Turbo Pascal 5.0. See DDJ for 4/89.
;
; Declare the procedure itself as external using this declaration:
;
; PROCEDURE BlkBlast(ScreenEnd,StoreEnd : Pointer;
; ScreenX,ScreenY : Integer;
; ULX,ULY : Integer;
; Width,Height : Integer;
; Attribute : Byte;
; DeadLines : Integer;
; TopStop : Integer);
; EXTERNAL;
;
; The idea is to store a video pattern as an assembly-language external or
; as a typed constant, and then blast it into memory so that it isn't seen
; to "flow" down from top to bottom, even on 8088 machines.
;
; During the blast itself, the attribute byte passed in the Attribute
; parameter is written to the screen along with the character information
; pointed to by the source pointer. In effect, this means we do a byte-sized
; read from the source character data, but a word-sized write to the screen.
;
; The DeadLines parm specifies how many screen lines to skip between lines of
; the pattern. The skipped lines are not disturbed. TopStop provides a byte
; count that is the maximum number of bytes to blast in from the pattern.
; If a 0 is passed in TopStop, the value is ignored.
;
; To reassemble BLKBLAST:
;
; Assemble this file with MASM or TASM: "C>MASM BLKBLAST;"
; (The semicolon is unnecessary with TASM.)
;
; No need to relink; Turbo Pascal uses the .OBJ only.
;
;========================
;
; STACK PROTOCOL
;
; This creature puts lots of things on the stack. Study closely:
;
ONSTACK STRUC
OldBP DW ? ;Caller's BP value saved on the stack
RetAddr DD ? ;Full 32-bit return address. (This is a FAR proc!)
TopStop DW ? ;Maximum number of chars to be copied from block pattern
DeadLns DW ? ;Number of lines of dead space to insert between blasted lines
Attr DW ? ;Attribute to be added to blasted pattern
BHeight DW ? ;Height of block to be blasted to the screen
BWidth DW ? ;Width of block to be blasted to the screen
ULY DW ? ;Y coordinate of upper left corner of the block
ULX DW ? ;X coordinate of the upper left corner of the block
YSize DW ? ;Genned max Y dimension of current visible screen
XSize DW ? ;Genned max X dimension of current visible screen
Block DD ? ;32-bit pointer to block pattern somewhere in memory
Screen DD ? ;32-bit pointer to an array of pointers to screen lines
ENDMRK DB ? ;Dummy field for stack struct size calculation
ONSTACK ENDS
CODE SEGMENT PUBLIC
ASSUME CS:CODE
PUBLIC BlkBlast
BlkBlast PROC FAR
PUSH BP ;Save Turbo Pascal's BP value
MOV BP,SP ;SP becomes new value in BP
PUSH DS ;Save Turbo Pascal's DS value
;-------------------------------------------------------------------------
; If a zero is passed in TopStop, then we fill the TopStop field in the
; struct with the full size of the block, calculated by multiplying
; BWidth times BHeight. This makes it unnecessary for the caller to
; pass the full size of the block in the TopStop parameter if topstopping
; is not required.
;-------------------------------------------------------------------------
CMP [BP].TopStop,0 ; See if zero was passed in TopStop
JNZ GetPtrs ; If not, skip this operation
MOV AX,[BP].BWidth ; Load block width into AX
MUL [BP].BHeight ; Multiply by block height, to AX
MOV [BP].TopStop,AX ; Put the product back into TopStop
;-------------------------------------------------------------------------
; The first important task is to get the first pointer in the ShowPtrs
; array into ES:DI. This involved two LES operations: The first to get
; the pointer to ShowPtrs (field Screen in the stack struct) into ES:DI,
; the second to use ES:DI to get the first ShowPtrs pointer into ES:DI.
; Remembering that ShowPtrs is an *array* of pointers, the next task is
; to index DI into the array by multiplying the top line number (ULY)
; less one (because we're one-based) by 4 using SHL and then adding that
; index to DI:
;-------------------------------------------------------------------------
GetPtrs: LES DI,[BP].Screen ; Address of ShowPtrs array in ES:DI
MOV CX,[BP].ULY ; Load line address of block dest. to CX
DEC CX ; Subtract 1 'cause we're one-based
SHL CX,1 ; Multiply CX by 4 by shifting it left...
SHL CX,1 ; ...twice.
ADD DI,CX ; Add the resulting index to DI.
MOV BX,DI ; Copy offset of ShowPtrs into BX
MOV DX,ES ; Copy segment of ShowPtrs into DX
LES DI,ES:[DI] ; Load first line pointer into ES:DI
;-------------------------------------------------------------------------
; The inset from the left margin of the block's destination is given in
; struct field ULX. It's one-based, so it has to be decremented by one,
; then multiplied by two using SHL since each character atom is two bytes
; in size. The value in the stack frame is adjusted (it's not a VAR parm,
; so that's safe) and then read from the frame at the start of each line
; blast and added to the line offset in DI.
;-------------------------------------------------------------------------
DEC [BP].ULX ; Subtract 1 'cause we're one-based
SHL [BP].ULX,1 ; Multiply by 2 to cover word moves
ADD DI,[BP].ULX ; And add the adjustment to DI
;-------------------------------------------------------------------------
; One additional adjustment must be made before we start: The Deadspace
; parm puts 1 or more lines of empty space between each line of the block
; that we're blasting onto the screen. This value is passed in the
; DEADLNS field in the struct. It's passed as the number of lines to skip,
; but we have to multiply it by 4 so that it becomes an index into the
; ShowPtrs array, each element of which is four bytes in size. Like ULX,
; the value is adjusted in the stack frame and added to the stored offset
; value we keep in DX each time we set up the pointer in ES:DI to blast the
; next line.
;-------------------------------------------------------------------------
SHL [BP].DEADLNS,1 ; Shift dead space line count by 1...
SHL [BP].DEADLNS,1 ; ...and again to multiply by 4
LDS SI,[BP].Block ; Load pointer to block into DS:SI
;-------------------------------------------------------------------------
; This is the loop that does the actual block-blasting. Two counters are
; kept, and share CX by being separate values in CH and CL. After
; each line blast, both pointers are adjusted and the counters swapped,
; the LOOP counter decremented and tested, and then the counters swapped
; again.
;-------------------------------------------------------------------------
MovEm: MOV CX,[BP].BWidth ; Load atom counter into CH
MOV AH,BYTE PTR [BP].Attr ; Load attribute into AH
DoChar: LODSB ; Load char from block storage into AL
STOSW ; Store AX into ES:DI; increment DI by 2
LOOP DoChar ; Go back for next char if CX > 0
;-------------------------------------------------------------------------
; Immediately after a line is blasted from block to screen, we adjust.
; First we move the pointer in ES:DI to the next pointer in the
; Turbo Pascal ShowPtrs array. Note that the source pointer does NOT
; need adjusting. After blasting through one line of the source block,
; SI is left pointing at the first character of the next line of the
; source block. Also note the addition of the deadspace adjustment to
; BX *before* BX is copied into DI, so that the adjustment will be
; retained through all the rest of the lines moved. Finally, we subtract
; the number of characters in a line from TopStop, and see if there are
; fewer counts left in TopStop than there are characters in a block line.
; If so, we force BWidth to the number of remaining characters, and
; BHeight to one, so that we will blast only one remaining (short) line.
;-------------------------------------------------------------------------
MOV ES,DX ; Copy ShowPtrs segment from DX into ES
ADD BX,4 ; Bounce BX to next pointer offset
ADD BX,[BP].DeadLns ; Add deadspace adjustment to BX
LES DI,ES:[BX] ; Load next pointer into ES:DI
ADD DI,[BP].ULX ; Add adjustment for X offset into screen
MOV AX,[BP].TopStop ; Load current TopStop value into AX
SUB AX,[BP].BWidth ; Subtract BWidth from TopSTop value
JBE GoHome ; If TopStop is <= zero, we're done.
MOV [BP].TopStop,AX ; Put TopStop value back in stack struct
CMP AX,[BP].BWidth ; Compare what remains in TopStop to BWidth
JAE MovEm ; If at least one BWidth remains, loop again
MOV [BP].BWidth,AX ; Otherwise, replace BWidth with remainder
JMP MovEm ; and jump to last go-thru
;-------------------------------------------------------------------------
; When the outer loop is finished, the work is done. Restore registers
; and return to Turbo Pascal.
;-------------------------------------------------------------------------
GoHome: POP DS ; Restore Turbo Pascal's
MOV SP,BP ; Restore Turbo Pascal's stack pointer...
POP BP ; ...and BP
RET ENDMRK-RETADDR-4 ; Clean up stack and return as FAR proc!
; (would be ENDMRK-RETADDR-2 for NEAR...)
BlkBlast ENDP
CODE ENDS
END
[LISTING FIVE]
TITLE CalBlks -- External calendar pattern blocks
; By Jeff Duntemann -- TASM 1.0 -- Last modified 3/1/89
;
; For use with CALENDAR.PAS and BLKBLAST.ASM as described in DDJ 6/89
CODE SEGMENT WORD
ASSUME CS:CODE
CalFrame PROC FAR
PUBLIC CalFrame
DB '���������������������������'
DB '� �'
DB '���������������������������Ĵ'
DB '�Sun�Mon�Tue�Wed�Thu�Fri�Sat�'
DB '���������������������������Ĵ'
DB '� � � � � � � �'
DB '���������������������������Ĵ'
DB '� � � � � � � �'
DB '���������������������������Ĵ'
DB '� � � � � � � �'
DB '���������������������������Ĵ'
DB '� � � � � � � �'
DB '���������������������������Ĵ'
DB '� � � � � � � �'
DB '���������������������������Ĵ'
DB '� � � � � � � �'
DB '���������������������������;'
Calframe ENDP
CalData PROC FAR
PUBLIC CalData
DB ' � � � � � � �'
DB ' 1� 2� 3� 4� 5� 6� 7�'
DB ' 8� 9� 10� 11� 12� 13� 14�'
DB ' 15� 16� 17� 18� 19� 20� 21�'
DB ' 22� 23� 24� 25� 26� 27� 28�'
DB ' 29� 30� 31� � � � �'
DB ' � � � � � � �'
DB ' � � � � � � �'
