home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / OS2BAS.ZIP / CALTRAN.BAS < prev    next >
BASIC Source File  |  1989-07-28  |  11KB  |  325 lines
  1. '***********************************************************
  2. '* 
  3. '* Program Name: Cal.BAS
  4. '*
  5. '* Description : This is the transition version of CAL.BAS
  6. '*               It uses essentially the same I/O and flow
  7. '*               as the original CAL.BAS. All standard I/O
  8. '*               has been replaced with the routines from
  9. '*               WinStdIO.BAS (WinCLS, WinPrint, WinInput,
  10. '*               WinLocate, WinPos).
  11. '*
  12. '* Changes:      SKELETON main program added
  13. '*               I/O control moved to ClientWndProc (WMPAINT)
  14. '*               PrintCalendar uses WinXXX routines for I/O
  15. '*               GetInput uses WinXXX routines...
  16. '***********************************************************
  17.  
  18. '* Initial section from original CAL.BAS
  19. DEFINT A-Z               ' Default variable type is integer
  20.  
  21. ' Define a data type for the names of the months and the
  22. ' number of days in each:
  23. TYPE MonthType
  24.    Number AS INTEGER     ' Number of days in the month
  25.    MName AS STRING * 9   ' Name of the month
  26. END TYPE
  27.  
  28. ' Declare procedures used:
  29. DECLARE FUNCTION IsLeapYear% (N%)
  30. DECLARE FUNCTION GetInput% (hwnd&, hps&, Prompt$, Row%, LowVal%, HighVal%)
  31.  
  32. DECLARE SUB PrintCalendar (hwnd&, hps&, Year%, Month%)
  33. DECLARE SUB ComputeMonth (Year%, Month%, StartDay%, TotalDays%)
  34.  
  35. '*********         Initialization section        ***********
  36.  
  37. '** From SKELETON.BAS
  38.  
  39. REM $INCLUDE: 'PMBase.BI'
  40. REM $INCLUDE: 'WinStdIO.BI'
  41. REM $INCLUDE: 'OS2Def.BI'           Needed for POINTL type
  42. REM $INCLUDE: 'WinInput.BI'         Needed for WMCHAR constant
  43.  
  44. DIM aqmsg AS QMSG
  45.  
  46. flFrameFlags& = FCFTITLEBAR      OR FCFSYSMENU OR _
  47.                 FCFSIZEBORDER    OR FCFMINMAX  OR _
  48.                 FCFSHELLPOSITION OR FCFTASKLIST
  49.  
  50. szClientClass$ = "ClassName" + CHR$(0)
  51.  
  52. hab& = WinInitialize(0)
  53. hmq& = WinCreateMsgQueue(hab&, 0)
  54.  
  55. bool% = WinRegisterClass(_
  56.           hab&,_
  57.           MakeLong(VARSEG(szClientClass$), SADD(szClientClass$)),_
  58.           RegBas,_
  59.           0,_
  60.           0)
  61.  
  62. hwndFrame& = WinCreateStdWindow (_
  63.           HWNDDESKTOP,_
  64.           WSVISIBLE,_
  65.           MakeLong (VARSEG(flFrameFlags&), VARPTR(flFrameFlags&)),_
  66.           MakeLong (VARSEG(szClientClass$), SADD(szClientClass$)),_
  67.           0,_
  68.           0,_
  69.           0,_
  70.           0,_
  71.           MakeLong (VARSEG(hwndClient&), VARPTR(hwndClient&)))
  72.  
  73. '*** From original CAL.BAS
  74. DIM MonthData(1 TO 12) AS MonthType
  75.  
  76. ' Initialize month definitions from DATA statements below:
  77. FOR I = 1 TO 12
  78.    READ MonthData(I).MName, MonthData(I).Number
  79. NEXT
  80.  
  81. '**************         Message loop         ***************
  82.  
  83. WHILE WinGetMsg(hab&, MakeLong(VARSEG(aqmsg), VARPTR(aqmsg)), 0, 0, 0)
  84.   bool% = WinDispatchMsg(hab&, MakeLong(VARSEG(aqmsg), VARPTR(aqmsg)))
  85. WEND
  86.  
  87. '***********         Finalize section        ***************
  88.  
  89. bool% = WinDestroyWindow(hwndFrame&)
  90. bool% = WinDestroyMsgQueue(hmq&)
  91. bool% = WinTerminate(hab&)
  92.  
  93. END
  94.  
  95. '***********         Window procedure        ***************
  96.  
  97. '****
  98. '** ClientWndProc is mainly from SKELETON, but contains controls
  99. '** from the original CAL.BAS. WMCHAR is necessary to buffer
  100. '** characters for WinInput. InputIndex is used to tell what
  101. '** the current stage of input is.
  102. '**
  103. '** NOTE: GOTO is used to display prompt again. Loops are not
  104. '**       advised anywhere except in the message loop.
  105. FUNCTION ClientWndProc& (hwnd&, msg%, mp1&, mp2&) STATIC
  106.      DIM ClientRect AS RECTL
  107.      ClientWndProc&=0
  108.      SELECT CASE msg%
  109.      CASE WMCHAR         'Buffer characters
  110.         CALL KeyMsg(hwnd&, mp1&, mp2&)
  111.      CASE WMPAINT
  112.         hps&  = WinBeginPaint(hwnd&, 0,_
  113.                 MakeLong(VARSEG(ClientRect), VARPTR(ClientRect)))
  114.         BeginInput:
  115.            IF InputIndex% = 0 THEN    'Input Year
  116.                ' Get year as input:
  117.                CALL WinCLS(hwnd&, hps&)
  118.                Year = GetInput(hwnd&, hps&, "Year (1899 to 2099): ", 1, 1899, 2099)
  119.                IF Year <> 0 THEN
  120.                   InputIndex% = InputIndex% + 1
  121.                END IF
  122.            END IF
  123.            IF InputIndex% = 1 THEN    'Input Month
  124.                ' Get month as input:
  125.                Month = GetInput(hwnd&, hps&, "Month (1 to 12): ", 2, 1, 12)
  126.                IF Month <> 0 THEN
  127.                   InputIndex% = InputIndex% + 1
  128.                END IF
  129.            END IF
  130.            IF InputIndex% = 2 THEN     'Print Calendar
  131.                ' Print the calendar:
  132.                PrintCalendar hwnd&, hps&, Year, Month
  133.                InputIndex% = InputIndex% + 1
  134.            END IF
  135.            IF InputIndex% = 3 THEN     'Ask for another date
  136.                ' Another Date?
  137.                WinLocate hwnd&, hps&, 13, 1             ' Locate in 13th row, 1st column
  138.                WinPrintS hps&, "New Date? "             ' Keep cursor on same line
  139.                Resp$ = WinInkey$                        ' Wait for a key press
  140.                IF Resp$ <> "" THEN WinPrint hps&, Resp$ ' Print the key pressed
  141.                IF (UCASE$(Resp$)="Y") THEN
  142.                   InputIndex% = 0
  143.                   GOTO BeginInput        'If another date, display prompt
  144.                ELSEIF Resp$ <> "" THEN
  145.                   bool% = WinSendMsg(hwnd&, WMCLOSE, 0, 0)
  146.                END IF
  147.            END IF
  148.         bool% = WinEndPaint(hps&)
  149.      CASE ELSE        'Pass control to system for other messages
  150.         ClientWndProc& = WinDefWindowProc(hwnd&, msg%, mp1&, mp2&)
  151.      END SELECT
  152. END FUNCTION
  153.  
  154. ' Data for the months of a year:
  155. DATA January, 31, February, 28, March, 31
  156. DATA April, 30, May, 31, June, 30, July, 31, August, 31
  157. DATA September, 30, October, 31, November, 30, December, 31
  158. '
  159. ' ====================== COMPUTEMONTH ========================
  160. '     Computes the first day and the total days in a month.
  161. ' ============================================================
  162. '
  163. SUB ComputeMonth (Year, Month, StartDay, TotalDays) STATIC
  164.    SHARED MonthData() AS MonthType
  165.    CONST LEAP = 366 MOD 7
  166.    CONST NORMAL = 365 MOD 7
  167.  
  168.    ' Calculate total number of days (NumDays) since 1/1/1899.
  169.  
  170.    ' Start with whole years:
  171.    NumDays = 0
  172.    FOR I = 1899 TO Year - 1
  173.       IF IsLeapYear(I) THEN         ' If year is leap, add
  174.          NumDays = NumDays + LEAP   ' 366 MOD 7.
  175.       ELSE                          ' If normal year, add
  176.          NumDays = NumDays + NORMAL ' 365 MOD 7.
  177.       END IF
  178.    NEXT
  179.  
  180.    ' Next, add in days from whole months:
  181.    FOR I = 1 TO Month - 1
  182.       NumDays = NumDays + MonthData(I).Number
  183.    NEXT
  184.  
  185.    ' Set the number of days in the requested month:
  186.    TotalDays = MonthData(Month).Number
  187.  
  188.    ' Compensate if requested year is a leap year:
  189.    IF IsLeapYear(Year) THEN
  190.  
  191.       ' If after February, add one to total days:
  192.       IF Month > 2 THEN
  193.          NumDays = NumDays + 1
  194.  
  195.       ' If February, add one to the month's days:
  196.       ELSEIF Month = 2 THEN
  197.          TotalDays = TotalDays + 1
  198.  
  199.       END IF
  200.    END IF
  201.  
  202.    ' 1/1/1899 was a Sunday, so calculating "NumDays MOD 7"
  203.    ' gives the day of week (Sunday = 0, Monday = 1, Tuesday = 2,
  204.    ' and so on) for the first day of the input month:
  205.    StartDay = NumDays MOD 7
  206. END SUB
  207. '
  208. ' ======================== GETINPUT ==========================
  209. '       Prompts for input, then tests for a valid range.
  210. ' ============================================================
  211. '
  212. '****
  213. '** GetInput uses WinStdio routines to display and input text.
  214. '** These routines are very similar to the BASIC I/O statements.
  215. '** The main difference is that WinInput is a function which will
  216. '** return zero until the input is completed.
  217. FUNCTION GetInput (hwnd&, hps&, Prompt$, Row, LowVal, HighVal) STATIC
  218.  
  219.    ' Locate prompt at specified row, turn cursor on and
  220.    ' make it one character high:
  221.    WinLocate hwnd&, hps&, Row, 1
  222.    WinPrintS hps&, Prompt$
  223.  
  224.    ' Save column position:
  225.    Column = WinPos(hps&)
  226.  
  227.    ' Input value until it's within range:
  228.    WinLocate hwnd&, hps&, Row, Column   ' Locate cursor at end of prompt
  229.    WinPrint hps&, SPACE$(10)     ' Erase anything already there
  230.    WinLocate hwnd&, hps&, Row, Column   ' Relocate cursor at end of prompt
  231.    done% = WinInput(hps&, "", GetVal$)     ' Input value with no prompt
  232.    IF done% THEN
  233.      Value = VAL(GetVal$)
  234.      GetVal$ = ""
  235.    END IF
  236.    IF (Value < LowVal) OR (Value > HighVal) THEN done% = 0
  237.  
  238.    ' Return valid input as value of function:
  239.    IF done% THEN
  240.      GetInput = Value
  241.    ELSE
  242.      GetInput = 0
  243.    END IF
  244.  
  245. END FUNCTION
  246. '
  247. ' ====================== ISLEAPYEAR ==========================
  248. '         Determines if a year is a leap year or not.
  249. ' ============================================================
  250. '
  251. FUNCTION IsLeapYear (N) STATIC
  252.  
  253.    ' If the year is evenly divisible by 4 and not divisible
  254.    ' by 100, or if the year is evenly divisible by 400, then
  255.    ' it's a leap year:
  256.    IsLeapYear = (N MOD 4 = 0 AND N MOD 100 <> 0) OR (N MOD 400 = 0)
  257. END FUNCTION
  258. '
  259. ' ===================== PRINTCALENDAR ========================
  260. '     Prints a formatted calendar given the year and month.
  261. ' ============================================================
  262. '
  263. '****
  264. '** PrintCalendar uses WinStdio routines. WinLocate's are used
  265. '** instead of PRINT USING's to handle the proportional fonts.
  266.  
  267. SUB PrintCalendar (hwnd&, hps&, Year, Month) STATIC
  268. SHARED MonthData() AS MonthType
  269.  
  270.    ' Compute starting day (Su M Tu ...) and total days
  271.    ' for the month:
  272.    ComputeMonth Year, Month, StartDay, TotalDays
  273.    WinCLS hwnd&, hps&
  274.    Header$ = RTRIM$(MonthData(Month).MName) + "," + STR$(Year)
  275.  
  276.    ' Calculates location for centering month and year:
  277.    LeftMargin = (35 - LEN(Header$)) \ 2
  278.  
  279.    ' Print header:
  280.    WinPrintS hps&, SPACE$(LeftMargin)
  281.    WinPrint hps&, Header$
  282.    WinPrint hps&, ""
  283.    Row = WinCSRLIN(hwnd&, hps&)
  284.  
  285.       'WinLocate's used to compensate for proportional font
  286.       WinLocate hwnd&, hps&, Row, 1 + 0 * 5
  287.       WinPrint hps&, "Su"
  288.       WinLocate hwnd&, hps&, Row, 1 + 1 * 5
  289.       WinPrint hps&, " M"
  290.       WinLocate hwnd&, hps&, Row, 1 + 2 * 5
  291.       WinPrint hps&, "Tu"
  292.       WinLocate hwnd&, hps&, Row, 1 + 3 * 5
  293.       WinPrint hps&, " W"
  294.       WinLocate hwnd&, hps&, Row, 1 + 4 * 5
  295.       WinPrint hps&, "Th"
  296.       WinLocate hwnd&, hps&, Row, 1 + 5 * 5
  297.       WinPrint hps&, " F"
  298.       WinLocate hwnd&, hps&, Row, 1 + 6 * 5
  299.       WinPrint hps&, "Sa"
  300.       WinPrint hps&, ""
  301.  
  302.    ' Recalculate and print tab to the first day
  303.    ' of the month (Su M Tu ...):
  304.    Row = WinCSRLIN (hwnd&, hps&)
  305.    Column = 1 + StartDay * 5
  306.  
  307.    'WinLocate's used to compensate for proportional font
  308.    ' Print out the days of the month:
  309.    FOR I = 1 TO TotalDays
  310.       II$ = LTRIM$(RTRIM$(STR$(I)))
  311.       IF LEN(II$) = 1 THEN II$ = " " + II$
  312.       WinLocate hwnd&, hps&, Row, Column
  313.       WinPrintS hps&, II$
  314.       Column = Column + 5
  315.  
  316.       ' Advance to the next line when the cursor
  317.       ' is past column 32:
  318.       IF Column > 32 THEN
  319.         Row = Row + 1
  320.         Column = 1
  321.       END IF
  322.    NEXT
  323.  
  324. END SUB
  325.