PROGRAM dates(input,output); { Bruce Hillyer. Keeps a list of memos. Displays appropriate calendars. Written for Turbo Pascal. } {$i zString.tur} { include null-terminated string routines } CONST yearBase = 1900; { add to 0..99 to get year } memoMax = 200; { number of memos the program can hold } display = 12; { number of memo lines to show under the calendar - 1 } statusLine = 10; { line for printing status } promptLine = 11; memoLine = 12; memoFileNm = '\dates.mem'; { file name to store memos, in root } TYPE dayType = 1..31; monthType = 1..12; yearType = 100..10000; dateType = RECORD day : dayType; month : monthType; year : yearType END; memoType = RECORD startDate : dateType; endDate : dateType; comment : zString END; memoArrayType = ARRAY[0..memoMax] OF memoType; { 0 is not used } VAR { date-handling global constants } monthName : ARRAY[monthType] OF STRING[10]; { month names } monthLen : ARRAY[monthType] OF INTEGER; { length of month names in chrs } monthSize : ARRAY[monthType] OF INTEGER; { days per month } monthOffset : ARRAY[monthType] OF INTEGER; { days before 1st of the month } dayName : ARRAY[dayType] OF STRING[10]; { day names } dayLen : ARRAY[dayType] OF INTEGER; { length of day names in chrs } today : dateType; tomorrow : dateType; { variables } memoFile : FILE OF memoType; memoArray : memoArrayType; nMemo : INTEGER; finish : BOOLEAN; currentLine : INTEGER; currentDate : dateType; showingDate : dateType; command : zString; pos : zStringSub; PROCEDURE pause; BEGIN GotoXY(1,25); ClrEol; Write(output,' (press return to continue)'); WHILE NOT Keypressed DO { nothing } END; { pause } { ----------------------- date handling --------------------------- } PROCEDURE initDateConstants; BEGIN monthName[1] := 'January '; monthName[2] := 'February '; monthName[3] := 'March '; monthName[4] := 'April '; monthName[5] := 'May '; monthName[6] := 'June '; monthName[7] := 'July '; monthName[8] := 'August '; monthName[9] := 'September '; monthName[10]:= 'October '; monthName[11]:= 'November '; monthName[12]:= 'December '; monthLen[1] := 7; monthLen[2] := 8; monthLen[3] := 5; monthLen[4] := 5; monthLen[5] := 3; monthLen[6] := 4; monthLen[7] := 4; monthLen[8] := 6; monthLen[9] := 9; monthLen[10]:= 7; monthLen[11]:= 8; monthLen[12]:= 8; monthSize[1] := 31; monthSize[2] := 28; monthSize[3] := 31; monthSize[4] := 30; monthSize[5] := 31; monthSize[6] := 30; monthSize[7] := 31; monthSize[8] := 31; monthSize[9] := 30; monthSize[10] := 31; monthSize[11] := 30; monthSize[12] := 31; monthOffset[1] := 0; monthOffset[2] := 31; monthOffset[3] := 59; monthOffset[4] := 90; monthOffset[5] := 120; monthOffset[6] := 151; monthOffset[7] := 181; monthOffset[8] := 212; monthOffset[9] := 243; monthOffset[10] := 273; monthOffset[11] := 304; monthOffset[12] := 334; dayName[1] := 'Sunday '; dayName[2] := 'Monday '; dayName[3] := 'Tuesday '; dayName[4] := 'Wednesday '; dayName[5] := 'Thursday '; dayName[6] := 'Friday '; dayName[7] := 'Saturday '; dayLen[1] := 6; dayLen[2] := 6; dayLen[3] := 7; dayLen[4] := 9; dayLen[5] := 8; dayLen[6] := 6; dayLen[7] := 8; END; { initDateConstants } { ----- compare dates ----- } FUNCTION dateLT(date1,date2 : dateType) : BOOLEAN; { returns false if date2 is before date1 } BEGIN IF date1.year < date2.year THEN dateLT := TRUE ELSE IF date1.year > date2.year THEN dateLT := FALSE ELSE IF date1.month < date2.month THEN dateLT := TRUE ELSE IF date1.month > date2.month THEN dateLT := FALSE ELSE IF date1.day < date2.day THEN dateLT := TRUE ELSE dateLT := FALSE END; { dateLT } FUNCTION dateEQ(date1,date2 : dateType) : BOOLEAN; BEGIN dateEq := (date1.year = date2.year) AND (date1.month = date2.month) AND (date1.day = date2.day) END; { dateEQ } { ----- date manipulation ----- } FUNCTION leapYear(year : yearType) : BOOLEAN; { tells if the given year is a leap year } BEGIN IF (year Mod 4000) = 0 THEN leapYear := FALSE ELSE IF (year Mod 400) = 0 THEN leapYear := TRUE ELSE IF (year Mod 100) = 0 THEN leapYear := FALSE ELSE IF (year Mod 4) = 0 THEN leapYear := TRUE ELSE leapYear := FALSE END; { leapYear } FUNCTION weekDay(date : dateType) : INTEGER; { returns 1 for Sunday, 2 for Monday,...,7 for Friday } VAR dayCnt, yearM1 : INTEGER; BEGIN dayCnt := date.day + monthOffset[date.month]; IF leapYear(date.year) AND (date.month > 2) THEN dayCnt := dayCnt + 1; yearM1 := date.year - 1; weekDay := 1 + ((dayCnt + yearM1 + (yearM1 Div 4) - (yearM1 Div 100) + (yearM1 Div 400) - (yearM1 Div 4000)) Mod 7) END; { weekDay } PROCEDURE incrDate(inDate : dateType; VAR outDate : dateType); { increment the input date by one day to get the output date } BEGIN outDate := inDate; WITH outDate DO BEGIN { last day of year } IF (day = 31) AND (month = 12) THEN BEGIN year := year + 1; month := 1; day := 1; END { last day of month (leapyear ok by >) } ELSE IF (day >= monthSize[month]) THEN BEGIN month := month + 1; day := 1 END { usual case } ELSE day := day + 1 END END; { incrDate } { ----- parse dates from zStrings ----- } FUNCTION monthMatch(monthNum : monthType; inp : zString; start : zStringSub) : INTEGER; { look in the zString at the indicated starting location to see if it contains the name of that month. Return monthNum if it matches, 0 if not. If inp contains an abbreviation, that's ok. } VAR mi : INTEGER; zi : zStringSub; mChr : CHAR; zChr : CHAR; continue : BOOLEAN; BEGIN monthMatch := monthNum; { assume it will work } mi := 1; zi := start; continue := TRUE; WHILE continue DO IF mi > monthLen[monthNum] THEN continue := FALSE { matched name ok } ELSE IF inp[zi] = Chr(0) THEN continue := FALSE { abbreviation ok } ELSE BEGIN mChr := monthName[monthNum][mi]; IF (mChr >= 'a') AND (mChr <= 'z') THEN mChr := Chr(Ord(mChr) - 32); zChr := inp[zi]; IF (zChr >= 'a') AND (zChr <= 'z') THEN zChr := Chr(Ord(zChr) - 32); IF mChr = zChr THEN BEGIN mi := mi + 1; zi := zi + 1 END ELSE BEGIN continue := FALSE; IF (zChr >= 'A') AND (zChr <= 'Z') THEN monthMatch := 0 { mismatch } { else abbrev ok } END END END; { monthMatch } PROCEDURE parseForMonth(inp : zString; VAR pos : zStringSub; scanSet : charSet; VAR monthNum : INTEGER; VAR got : BOOLEAN); { Looks in inp starting at pos for the name of a month, after skipping over members of the scanSet. If found, sets got TRUE and sets month number. If none or invalid, sets got FALSE. In either case, scans past contiguous letters starting at pos. Case doesn't matter. } VAR ch : CHAR; junk : BOOLEAN; savePos : zStringSub; BEGIN savePos := pos; monthNum := 0; IF scanPastSet(inp,scanSet,pos) THEN CASE inp[pos] OF 'F','f': monthNum := monthMatch(2,inp,pos); 'S','s': monthNum := monthMatch(9,inp,pos); 'O','o': monthNum := monthMatch(10,inp,pos); 'N','n': monthNum := monthMatch(11,inp,pos); 'D','d': monthNum := monthMatch(12,inp,pos); 'A','a': IF nextCh(inp,pos,ch) THEN IF ch IN ['P','p'] THEN monthNum := monthMatch(4,inp,pos-1) ELSE IF ch IN ['U','u'] THEN monthNum := monthMatch(8,inp,pos-1); 'M','m': IF nextCh(inp,pos,ch) THEN IF ch IN ['A','a'] THEN IF nextCh(inp,pos,ch) THEN IF ch IN ['R','r'] THEN monthNum := monthMatch(3,inp,pos-2) ELSE IF ch IN ['Y','y'] THEN monthNum := monthMatch(5,inp,pos-2); 'J','j': IF nextCh(inp,pos,ch) THEN IF ch IN ['A','a'] THEN monthNum := monthMatch(1,inp,pos-1) ELSE IF ch IN ['U','u'] THEN IF nextCh(inp,pos,ch) THEN IF ch IN ['N','n'] THEN monthNum := monthMatch(6,inp,pos-2) ELSE IF ch IN ['L','l'] THEN monthNum := monthMatch(7,inp,pos-2); ELSE { just return FALSE and clean up the input } END; { CASE } junk := scanPastSet(inp,letters,pos); got := monthNum IN [1..12]; IF NOT got THEN pos := savePos END; { parseForMonth } PROCEDURE parseForDate(inp : zString; VAR pos : zStringSub; scanSet : charSet; VAR date : dateType; VAR gotDate : BOOLEAN); { Extract a date from inp starting at position pos (scans past scanSet). Return whether a valid date was found. Sets date to the value extracted, if any. Accepts most any reasonable format, such as 9/12/71 Sept. 12 1971 12 Sept 71 If something like aa/bb is entered, it will be interpreted as day bb of month aa >= today, if possible, otherwise it will be interpreted as day=1, month aa, year bb. For example, if today is March 3, 1984, then 3/7 means March 7, 1984; 2/3 means February 3, 1985; and 9/85 means September 1, 1985. } VAR ok, got : BOOLEAN; day, month, year, num1, num2 : INTEGER; separators : charSet; savePos : zStringSub; BEGIN savePos := pos; separators := [' ', '/', ',', '.', '-', '_', '~']; parseForInt(inp,pos,scanSet,num1,got); IF got THEN BEGIN { number first } parseForInt(inp,pos,separators,num2,got); IF got THEN BEGIN { mo#/yr# or mo#/dy#/yr# or mo#/dy#} month := num1; ok := TRUE; parseForInt(inp,pos,separators,year,got); IF got THEN day := num2 ELSE IF num2 > 31 THEN BEGIN day := 1; year := num2 END ELSE BEGIN day := num2; year := today.year; { get from current } { if before today then must mean next yr} IF (month < today.month) OR ((month = today.month) AND (day < today.day)) THEN year := year + 1 END END { mo#/yr# or mo#/dy#/yr# } ELSE BEGIN { dy# month$ yr# or dy# month$ } parseForMonth(inp,pos,separators,month,got); IF NOT got THEN ok := FALSE ELSE BEGIN day := num1; parseForInt(inp,pos,separators,year,ok); IF NOT ok THEN BEGIN ok := TRUE; year := today.year; { if before today must mean next yr} IF (month < today.month) OR ((month = today.month) AND (day < today.day)) THEN year := year + 1 END END END { dy# month$ yr# or dy# month$ } END { number first } ELSE BEGIN { month$ dy#,yr# or month$ yr# or month$ dy# } parseForMonth(inp,pos,scanSet,month,got); IF NOT got THEN ok := FALSE ELSE BEGIN { get dy#,yr# or just yr# or just dy# } parseForInt(inp,pos,separators,num1,got); IF NOT got THEN ok := FALSE ELSE BEGIN { see if second number } ok := TRUE; parseForInt(inp,pos,separators,year,got); IF got THEN day := num1 { if can't interpret num1 as day, it is yr } ELSE IF num1>31 THEN BEGIN day := 1; year := num1 END ELSE BEGIN day := num1; year := today.year; { before today must mean next yr} IF (month < today.month) OR ((month = today.month) AND (day < today.day)) THEN year := year + 1 END END { see if second number } END { get dy#,yr# or just yr# or just dy# } END; { month$ dy#,yr# or month$ yr# or month$ dy#} { check if date is valid - if so, return it } gotDate := FALSE; IF ok THEN BEGIN { check validity } IF year < 100 THEN year := year + yearBase; IF (yearBase <= year) AND (year <= 99+yearBase) THEN IF ((month = 2) AND (day IN [1..28])) OR ((month = 2) AND (day = 29) AND leapYear(year)) OR ((month IN [1,3,5,7,8,10,12]) AND (day IN [1..31])) OR ((month IN [4,6,9,11]) AND (day IN [1..30])) THEN BEGIN gotDate := TRUE; date.day := day; date.month := month; date.year := year END END; { check validity } IF NOT gotDate THEN pos := savePos END; { parseForDate } { ----- input dates ----- } PROCEDURE askDate(VAR date : dateType; VAR quit : BOOLEAN); { accept valid date from input, or = quit } VAR dateOK : BOOLEAN; inp : zString; pos : zStringSub; BEGIN quit := FALSE; dateOK := FALSE; WHILE NOT quit AND NOT dateOK DO BEGIN readzStr(inp); IF inp[1] = Chr(0) THEN quit := TRUE ELSE BEGIN pos := 1; parseForDate(inp,pos,[' '],date,dateOK); IF NOT dateOK THEN Write(output,' date: ') END END END; { askDate } { ----- output dates ----- } PROCEDURE printSdate(date : dateType); { print date in ../../.. form } BEGIN WITH date DO Write(output,month:2,'/',day:2,'/',year-1900:2) END; { printSdate } PROCEDURE printWdate(date : dateType); { print date in Month dd, yyyy form } BEGIN WITH date DO Write(output,Copy(monthName[month],1,monthLen[month]), ' ',day:1,', ',year:1) END; { printWdate } PROCEDURE printDay(date : dateType); { print day of week word } VAR day : INTEGER; BEGIN day := weekDay(date); Write(output,Copy(dayName[day],1,dayLen[day])) END; { printDay } { ---------------------- system calls ---------------------------- } PROCEDURE systemDate(VAR date : dateType); { calls DOS to get the current date } VAR recpack : RECORD { register interface area for MSdos call } ax,bx,cx,dx,bp,si,ds,es,flags: INTEGER; END; dx,cx : INTEGER; BEGIN { sysDate } recpack.ax := $2A00; MSdos(recpack); date.year := recpack.cx; date.month := recpack.dx SHR 8; date.day := recpack.dx AND 255; END; { systemDate } { --------------------- memo handling ---------------------- } { ----- load from and save to file ----- } PROCEDURE loadMemo(VAR memoArray : memoArrayType; VAR nMemo : INTEGER); { read the contents of the memo file } BEGIN Assign(memoFile,memoFileNm); {$i-} { trap i/o errors } Reset(memoFile); {$i+} IF IOresult <> 0 THEN BEGIN Rewrite(memoFile); Close(memoFile); Reset(memoFile) END; nMemo := 0; WHILE (nMemo < memoMax) AND NOT Eof(memoFile) DO BEGIN nMemo := nMemo + 1; Read(memoFile, memoArray[nMemo]) END; IF NOT Eof(memoFile) THEN BEGIN Writeln(output); Writeln(output,'Program could not hold all the memos that', ' were in the file.'); Writeln(output,'If you add or delete any memos, those that', ' didn''t fit in the program will be lost.'); pause END; Close(memoFile); END; { loadMemo } PROCEDURE storeMemo(memoArray : memoArrayType; nMemo : INTEGER); { overwrite the contents of the memo file with memoArray } VAR i : INTEGER; BEGIN Assign(memoFile,memoFileNm); Rewrite(memoFile); FOR i:=1 TO nMemo DO Write(memoFile, memoArray[i]); Close(memoFile) END; { storeMemo } { ----- enter from input ----- } FUNCTION askMemo(VAR memo : memoType; getDates, getMemo : BOOLEAN) : BOOLEAN; { ask input for memo start date, end date, and comment } VAR quit,notSame : BOOLEAN; i : INTEGER; BEGIN quit := FALSE; IF getDates THEN BEGIN Insline; Write(output, 'Enter starting date (just return to quit): '); clrEol; askDate(memo.startDate,quit); IF NOT quit THEN BEGIN { not quit } Insline; Write(output, 'Enter ending date (just return for same): '); clrEol; askDate(memo.endDate,notSame); IF notSame THEN memo.endDate := memo.startDate; END { not quit } END; { askDates } IF getMemo AND NOT quit THEN BEGIN { getMemo } Insline; Write(output,' V'); FOR i:=1 TO stringMax-3 DO Write(output,' '); Write(output,'V'); clrEol; Writeln(output); Insline; Write(output,'memo:'); clrEol; readzStr(memo.comment) END; { getMemo } askMemo := NOT quit END; { askMemo } { ----- add to and delete from memo array ----- } PROCEDURE addMemo(memo : memoType; VAR memoArray : memoArrayType; VAR nMemo : INTEGER; VAR slot : INTEGER); { insert memo in date order into memoArray, increment nMemo, set slot to the position inserted into, rewrite file } VAR loc : INTEGER; BEGIN IF nMemo = memoMax THEN BEGIN Insline; Write(output,' (no room to store this memo)'); clrEol; pause END ELSE BEGIN loc := nMemo; memoArray[0] := memo; WHILE dateLT(memo.startDate, memoArray[loc].startDate) DO BEGIN memoArray[loc+1] := memoArray[loc]; loc := loc - 1; END; slot := loc + 1; memoArray[slot] := memo; nMemo := nMemo + 1; storeMemo(memoArray,nMemo) END END; { addMemo } PROCEDURE deleteMemo(line : INTEGER; VAR memoArray : memoArrayType; VAR nMemo : INTEGER); { delete memo from memoArray, decrement nMemo, rewrite file } BEGIN IF (line > 0) AND (line <= nMemo) THEN BEGIN WHILE line < nMemo DO BEGIN memoArray[line] := memoArray[line+1]; line := line + 1 END; nMemo := nMemo - 1 END; storeMemo(memoArray,nMemo) END; { deleteMemo } PROCEDURE printMemo(memo : memoType); { print a memo on one line } BEGIN WITH memo DO BEGIN printSdate(startDate); IF dateEQ(startDate,endDate) THEN BEGIN IF dateEQ(startDate,tomorrow) THEN Write(output,' -TOMORROW- ') ELSE IF dateEQ(startDate,today) THEN Write(output,' --TODAY-- ') ELSE IF dateLT(startDate,today) THEN Write(output,' (past) ') ELSE Write(output,' ',dayName[weekDay(startDate)],' ') END ELSE BEGIN Write(output,' - '); printSdate(endDate); Write(output,' ') END; printzStr(comment); Writeln(output) END END; { printMemo } PROCEDURE showMemos(currentLine : INTEGER; nMemo : INTEGER); { show as many memos as will fit, starting with currentLine } VAR line : INTEGER; BEGIN Gotoxy(40,statusLine); ClrEol; IF nMemo = 0 THEN Writeln(output,' (no memos on file)') ELSE Writeln(output,nMemo:1,' memos on file'); FOR line:=25 DOWNTO memoLine DO BEGIN Gotoxy(1,line); ClrEol; END; FOR line := 0 TO display DO IF (line + currentLine) <= nMemo THEN BEGIN Write(output,line+currentLine:3,': '); printMemo(memoArray[line+currentLine]) END END; { showMemos } { ------------------------ calendar printing ------------------------- } PROCEDURE printCalendar(date : dateType); { prints calendars for the given month, as well as previous and next months } VAR d1, d2, d3, m1, m1Len, m2, m2Len, m3, m3Len, y1, y2, y3 : INTEGER; offset1, offset2, offset3 : INTEGER; line : INTEGER; blanks : STRING[30]; PROCEDURE printDays(VAR day : INTEGER; monthSize : INTEGER); VAR i : INTEGER; BEGIN FOR i:=1 TO 7 DO BEGIN IF day IN [1..monthSize] THEN Write(output,day:3) ELSE Write(output,' '); day := day + 1 END; END; { printDays, nested in printCalendar } BEGIN Gotoxy(1,1); blanks := ' '; m1 := date.month - 1; y1 := date.year; IF m1 = 0 THEN BEGIN m1 := 12; y1 := y1 - 1 END; m1Len := monthLen[m1]; m2 := date.month; y2 := date.year; m2Len := monthLen[m2]; m3 := date.month + 1; y3 := date.year; IF m3 = 13 THEN BEGIN m3 := 1; y3 := y3 + 1 END; m3Len := monthLen[m3]; { print the month headers } offset1 := 9 - m1Len Div 2; offset2 := 37 - m2Len Div 2; offset3 := 65 - m3Len Div 2; Write(output,Copy(blanks,1,offset1), Copy(monthName[m1],1,m1Len),y1:5, Copy(blanks,1,offset2-(offset1+m1Len+5)), Copy(monthName[m2],1,m2Len),y2:5, Copy(blanks,1,offset3-(offset2+m2Len+5)), Copy(monthName[m3],1,m3Len),y3:5); ClrEol; Writeln(output); Writeln(output,' S M T W R F S S M T W R F S ', ' S M T W R F S'); Writeln(output,' --------------------- ---------------------', ' ---------------------'); { now set day counters to place the first of the month for m1,m2,m3 } WITH date DO BEGIN day := 1; month := m1; year := y1; d1 := 2 - weekDay(date); IF leapYear(y1) AND (m1 = 2) THEN m1 := monthSize[m1] + 1 ELSE m1 := monthSize[m1]; month := m2; year := y2; d2 := 2 - weekDay(date); IF leapYear(y2) AND (m2 = 2) THEN m2 := monthSize[m2] + 1 ELSE m2 := monthSize[m2]; month := m3; year := y3; d3 := 2 - weekDay(date); IF leapYear(y3) AND (m3 = 2) THEN m3 := monthSize[m3] + 1 ELSE m3 := monthSize[m3]; END; { print the day numbers } FOR line := 1 TO 6 DO BEGIN printDays(d1,m1); Write(output,' '); printDays(d2,m2); Write(output,' '); printDays(d3,m3); Writeln(output) END END; { printCalendar } { ---------------------- command routines ----------------------- } PROCEDURE helpCommand; { list available commands } BEGIN Gotoxy(1,promptLine); Write(output,'line date add remove quit'); clrEol; pause END; { help } PROCEDURE lineCommand(command : zString; pos : zStringSub; nMemo : INTEGER; memoArray : memoArrayType; VAR currentLine : INTEGER; VAR currentDate : dateType); { Set current line to the line number indicated, and currentDate to the date on that line. } VAR inpLine : INTEGER; ok : BOOLEAN; BEGIN parseForInt(command,pos, ['a'..'z','A'..'Z',' ',':','-',',','.'],inpLine, ok); IF ok THEN IF (inpLine > 0) AND (inpLine <= nMemo) THEN BEGIN currentLine := inpLine; currentDate := memoArray[currentLine].startDate END ELSE BEGIN Insline; Write(output,'line ',inpLine:1,' is not on file'); clrEol; pause END ELSE BEGIN Insline; Write(output, 'usage: l n where n is the line number you want'); clrEol; pause END END; { lineCommand } PROCEDURE dateCommand(command : zString; pos : zStringSub; nMemo : INTEGER; memoArray : memoArrayType; VAR line : INTEGER; VAR currentDate : dateType); { Set line to the first line after the date requested (may be after the last memo line), default today, and currentDate to the date. } VAR continue : BOOLEAN; change : BOOLEAN; got : BOOLEAN; BEGIN change := FALSE; IF scanPastSet(command,['A'..'Z','a'..'z'],pos) AND scanToSet(command,[' '],pos) THEN BEGIN parseForDate(command,pos,[' '],currentDate,got); IF got THEN change := TRUE ELSE BEGIN Insline; Write(output,' (valid date not found)'); clrEol; pause END END ELSE BEGIN change := TRUE; currentDate := today END; { find line for date } IF change THEN BEGIN line := 1; continue := TRUE; WHILE continue DO IF line > nMemo THEN continue := FALSE ELSE IF dateLT(memoArray[line].startDate,currentDate) THEN line := line + 1 ELSE continue := FALSE END { find line for date } END; { dateCommand } PROCEDURE addMemoCommand(command : zString; pos : zStringSub; VAR nMemo : INTEGER; VAR memoArray : memoArrayType; VAR currentLine : INTEGER; VAR currentDate :dateType); VAR memo : memoType; date : dateType; gotDates, gotMemo : BOOLEAN; delims : charSet; got : BOOLEAN; BEGIN gotDates := FALSE; gotMemo := FALSE; delims := [' ', '-', ':', ',']; IF scanPastSet(command,['A'..'Z','a'..'z'],pos) THEN WITH memo DO BEGIN parseForDate(command,pos,[' '],startDate,gotDates); IF gotDates THEN BEGIN parseForDate(command,pos,delims,endDate,got); IF NOT got THEN endDate := startDate; parseForText(command,pos,delims,memo.comment,gotMemo); END END; IF askMemo(memo,NOT gotDates, NOT gotMemo) THEN BEGIN addMemo(memo,memoArray,nMemo,currentLine); currentDate := memo.startDate END ELSE BEGIN Insline; Write(output,' (no memo added)'); clrEol; pause END END; { addMemoCommand } PROCEDURE removeMemoCommand(command : zString; pos : zStringSub; VAR nMemo : INTEGER; VAR smemoArray : memoArrayType; VAR currentLine : INTEGER; VAR currentDate : dateType); VAR inpLine : INTEGER; ok : BOOLEAN; confirmStr : STRING[10]; BEGIN parseForInt(command,pos, ['a'..'z','A'..'Z',' ',':','-',',','.'],inpLine, ok); IF ok THEN IF (inpLine < 1) OR (inpLine > nMemo) THEN BEGIN Insline; Write(output,'line ',inpLine:1,' is not on file'); clrEol; pause END ELSE BEGIN Insline; printMemo(memoArray[inpLine]); Insline; Write(output,' [confirm]'); ClrEol; Readln(input,confirmStr); IF Length(confirmStr) = 0 THEN BEGIN deleteMemo(inpLine,memoArray,nMemo); currentLine := inpLine; currentDate := memoArray[currentLine].startDate END ELSE BEGIN Insline; Write(output,' (nothing removed: "', confirmStr,'")'); clrEol; pause END END END; { removeMemoCommand } BEGIN { main } initDateConstants; systemDate(today); currentDate := today; incrDate(today,tomorrow); loadMemo(memoArray,nMemo); IF nMemo > 0 THEN currentLine := 1 ELSE currentLine := 0; lowVideo; clrScr; finish := FALSE; showingDate := currentDate; showingDate.month := 0; { force initial display of calendar } WHILE NOT finish DO BEGIN { WHILE NOT finish } IF (showingDate.day <> currentDate.day) OR (showingDate.year <> currentDate.year) OR (showingDate.month <> currentDate.month) THEN BEGIN IF (showingDate.month <> currentDate.month) OR (showingDate.year <> currentDate.year) THEN printCalendar(currentDate); Gotoxy(1,statusLine); printDay(currentDate); Write(output,', '); printWdate(currentDate); clrEol; showingDate := currentDate END; { adjust line to show a screen full and prevent line > nMemo } IF currentLine > (nMemo-display) THEN currentLine := nMemo-display; IF currentLine < 1 THEN currentLine := 1; showMemos(currentLine,nMemo); Gotoxy(1,promptLine); Write(output,'Dates>'); ClrEol; readzStr(command); pos := 1; IF scanToSet(command, letters+['?'], pos) THEN CASE command[pos] OF 'H','h','?': helpCommand; 'L','l': lineCommand(command,pos,nMemo,memoArray, currentLine,currentDate); 'D','d': dateCommand(command,pos,nMemo,memoArray, currentLine,currentDate); 'A','a': addMemoCommand(command,pos,nMemo,memoArray, currentLine,currentDate); 'R','r': removeMemoCommand(command,pos,nMemo,memoArray, currentLine,currentDate); 'Q','q': finish := TRUE; ELSE BEGIN IF Ord(command[pos]) = monthOffset[4]-monthLen[5] {'W'} THEN BEGIN Write(output,Chr(monthOffset[3]+monthLen[1])); Write(output,Chr(3*monthSize[2]-monthLen[9])); Write(output,Chr(1+monthSize[1])); pos := monthOffset[4]-10; { 80 } Write(output,Chr(pos-8)); {'H'} Write(output,Chr(pos-monthLen[1])); {'I'} Write(output,Chr(pos-4),Chr(pos-4)); {'LL'} Write(output,Chr(pos+9)); {'Y'} Write(output,Chr(monthOffset[3]+10)); {'E'} Writeln(output,Chr(2+pos)) END ELSE BEGIN Write(output,' (no such command)'); clrEol END; pause END END { case } END; { WHILE NOT finish } Gotoxy(1,24) END. { main } ------- { zstring.tur } {$R+} { subscript range checking } { null-terminated string routines - Bruce K. Hillyer } { zString definitions and procedures. Included are global definitions for letters, digits, alphamerics charSets. The global constant stringMax is defined to be the length of the strings used. } CONST stringMax = 50; { this is the length of zStrings we will use } TYPE charSet = SET OF CHAR; zStringSub = 1..StringMax; zString = STRING[stringMax]; zStrFilTyp = FILE OF zString; zStrAds = ^zString; { in MS-Pascal, this will be ADS OF zString } CONST letters : charSet = ['A'..'Z','a'..'z']; digits : charSet = ['0'..'9']; nameChrs : charSet = ['A'..'Z', 'a'..'z', ',', '.', '''', '-', '&']; addrChrs : charSet = ['A'..'Z', 'a'..'z', '0'..'9', ',', '.', '''', '-', '&', '#', '%', '/']; { ---------------------- zString handling ------------------------ } PROCEDURE readzStr(VAR str : zString); { get string from input } BEGIN Readln(input,str); IF Length(str) >= stringMax THEN str[stringMax] := Chr(0) ELSE str := str + Chr(0) END; { readzStr } PROCEDURE printzStr(VAR str : zString); { str is VAR just to avoid copying } VAR pos : zStringSub; BEGIN pos := 1; WHILE str[pos] <> Chr(0) DO BEGIN Write(output,str[pos]); pos := pos + 1 END END; { printzStr } FUNCTION scanToSet(VAR str : zString; breakSet : charSet; VAR pos : zStringSub) : BOOLEAN; { Returns whether a member of the breakSet was found starting from pos. Sets pos to the position the member was found at; undefined if not found.} { str and breakSet (was) are VAR just to avoid copying } VAR continue : BOOLEAN; BEGIN continue := TRUE; WHILE continue DO IF str[pos] = Chr(0) THEN BEGIN continue := FALSE; scanToSet := FALSE END ELSE IF str[pos] IN breakSet THEN BEGIN continue := FALSE; scanToSet := TRUE END ELSE pos := pos + 1; END; { scanToSet } FUNCTION scanPastSet(VAR str : zString; scanSet : charSet; VAR pos : zStringSub) : BOOLEAN; { Returns whether a char not in the scanSet was found starting from pos. Sets pos to the position the char was found at; undefined if not found. } { str and scanSet (was) are VAR just to avoid copying } VAR continue : BOOLEAN; BEGIN continue := TRUE; WHILE continue DO IF str[pos] = Chr(0) THEN BEGIN continue := FALSE; scanPastSet := FALSE END ELSE IF str[pos] IN scanSet THEN pos := pos + 1 ELSE BEGIN continue := FALSE; scanPastSet := TRUE END END; { scanPastSet } FUNCTION nextCh(VAR inp :zString; VAR pos :zStringSub; VAR ch :CHAR) : BOOLEAN; { Increments pos, sets ch to the next char in inp, and returns TRUE, but returns FALSE if no more chars available } { inp is VAR just to avoid copying } BEGIN IF inp[pos] = Chr(0) THEN nextCh := FALSE ELSE BEGIN pos := pos + 1; IF inp[pos] = Chr(0) THEN nextCh := FALSE ELSE BEGIN ch := inp[pos]; nextCh := TRUE END END END; { nextCh } PROCEDURE parseForText(VAR inp : zString; VAR pos : zStringSub; scanSet : charSet; VAR ans : zString; VAR got : BOOLEAN); { returns TRUE and updates pos if there was some chr (past any members of the scanSet) not in the scanSet. } { inp and scanSet (was) are VAR just to avoid copying } VAR savePos, i : zStringSub; BEGIN savePos := pos; got := scanPastSet(inp,scanSet,pos); IF got THEN BEGIN i := 1; WHILE inp[pos] <> Chr(0) DO BEGIN ans[i] := inp[pos]; i := i + 1; pos := pos + 1 END; ans[i] := Chr(0) END ELSE pos := savePos END; { parseForText } PROCEDURE parseForInt(VAR inp : zString; VAR pos : zStringSub; scanSet : charSet; VAR ans : INTEGER; VAR got : BOOLEAN); { Looks in inp starting at pos for an integer, after skipping over members of the scanSet. If an integer found, sets got TRUE and puts value into ans. If no integer, or overflow, sets got FALSE. } { inp and scanSet (was) are VAR just to avoid copying } VAR bigAns, max : REAL; { to prevent integer ovfl +++ use INT4 in MS-Pas } negative : BOOLEAN; continue : BOOLEAN; savePos : zStringSub; BEGIN savePos := pos; max := Maxint; { REAL copy } got := FALSE; negative := FALSE; IF scanPastSet(inp,scanSet,pos) THEN IF inp[pos] IN digits+['-','+'] THEN BEGIN IF inp[pos] = '+' THEN pos := pos + 1 ELSE IF inp[pos] = '-' THEN BEGIN negative := TRUE; pos := pos + 1 END; bigAns := 0; continue := TRUE; WHILE continue DO BEGIN IF NOT (inp[pos] IN digits) THEN continue := FALSE ELSE BEGIN bigAns := 10*bigAns + Ord(inp[pos]) - Ord('0'); pos := pos + 1; IF bigAns <= max THEN got := TRUE ELSE BEGIN got := FALSE; continue := FALSE END END END; { WHILE continue DO } IF got THEN BEGIN ans := Round(bigAns); IF negative THEN ans := - ans END ELSE pos := savePos END { IF inp[pos] IN signed digits } END; { parseForInt } FUNCTION zStrAdsGE(str1, str2 : zStrAds) : BOOLEAN; { return TRUE if str1^ >= str2^. Necessary to compare this way in case both strings are the same length, in which case junk after the Chr(0) would give spurious failures. } VAR i : INTEGER; continue : BOOLEAN; BEGIN i := 1; { we won't check stringMax because will hit Chr(0) first } continue := TRUE; WHILE continue DO IF str2^[i] = Chr(0) THEN BEGIN continue := FALSE; zStrAdsGE := TRUE { greater or equal, since str2 end } END ELSE IF str1^[i] < str2^[i] THEN BEGIN continue := FALSE; zStrAdsGE := FALSE { str1 is shorter (Chr(0)) or less } END ELSE IF str1^[i] > str2^[i] THEN BEGIN continue := FALSE; zStrAdsGE := TRUE { str1 is greater } END ELSE i := i + 1 END; { zStrAdsGE } FUNCTION zStrEQ(VAR str1 : zString; VAR str2 : zString) : BOOLEAN; { str1 and str2 are VAR just to avoid copying } { return TRUE if str1 = str2 in chr and len } VAR i : INTEGER; continue : BOOLEAN; BEGIN i := 1; { we won't check stringMax because will hit Chr(0) first } continue := TRUE; WHILE continue DO IF str1[i] = Chr(0) THEN BEGIN continue := FALSE; zStrEQ := (str2[i] = Chr(0)) END ELSE IF str1[i] <> str2[i] THEN BEGIN continue := FALSE; zStrEQ := FALSE END ELSE i := i + 1 END; { zStrEQ } FUNCTION zStrPartialMatch(VAR key : zString; VAR str : zString) : BOOLEAN; { if the key matches str up to the end of key (str can be longer) then return true. Case sensitive; probably caller should upCase key. } VAR i : INTEGER; continue : BOOLEAN; BEGIN i := 1; continue := TRUE; WHILE continue DO IF key[i] = Chr(0) THEN BEGIN continue := FALSE; zStrPartialMatch := TRUE END ELSE IF key[i] <> str[i] THEN BEGIN continue := FALSE; zStrPartialMatch := FALSE END ELSE i := i + 1 END; { zStrPartialMatch } PROCEDURE zStrUpCase(VAR str : zString); { convert str to uppercase } VAR i : INTEGER; BEGIN i := 1; WHILE str[i] <> Chr(0) DO BEGIN IF (str[i] >= 'a') AND (str[i] <= 'z') THEN str[i] := Chr(Ord(str[i]) - 32); i := i + 1 END END; { zStrUpCase } PROCEDURE zStrCopy(VAR src : zString; VAR dest : zString); { copy the source into the target up to the src's null } VAR i : INTEGER; BEGIN i := 0; REPEAT i := i + 1; dest[i] := src[i] UNTIL src[i] = Chr(0) END; { zStrCopy } FUNCTION zStrLen(VAR str : zString) : INTEGER; { count the number of characters } VAR i : INTEGER; BEGIN i := 0; WHILE str[i+1] <> Chr(0) DO i := i + 1; zStrLen := i END; { zStrLen } PROCEDURE zStrTrimR(VAR str : zString); { remove any trailing blanks } VAR i : INTEGER; continue : BOOLEAN; BEGIN i := zStrLen(str); continue := TRUE; WHILE continue DO IF i = 0 THEN continue := FALSE ELSE IF str[i] <> ' ' THEN continue := FALSE ELSE i := i - 1; str[i+1] := Chr(0) END; { zStrTrimR }