home *** CD-ROM | disk | FTP | other *** search
/ GEMini Atari / GEMini_Atari_CD-ROM_Walnut_Creek_December_1993.iso / files / acc / calendar / calndr / cal.gfa (.txt) next >
Encoding:
GFA-BASIC Atari  |  1992-12-22  |  5.4 KB  |  232 lines
  1. $m20000                   !memory space.
  2. DEFINT "a-z"        ! Make 'em all integers
  3. ap_id&=APPL_INIT()        !DA identity.
  4. IF ap_id&                 !Is this one my ID.
  5.   my_id&=MENU_REGISTER(ap_id&,"  Calendar")   !Yes it seems to be.
  6.   DO
  7.     ~EVNT_MESAG(0)
  8.     IF MENU(1)=40         !If DA has been opened
  9.       @get_data
  10.       @init
  11.       ON MENU MESSAGE GOSUB message
  12.       ON MENU KEY GOSUB mkey
  13.       REPEAT
  14.         ON MENU
  15.       UNTIL exit%
  16.       CLOSEW #1
  17.     ENDIF
  18.   LOOP
  19. ENDIF
  20. SYSTEM
  21. > PROCEDURE init                     ! Initialize things
  22.   ts%=4
  23.   pad%=42
  24.   IF rez%=2
  25.     ts%=13
  26.   ENDIF
  27.   DEFTEXT 1,1,0,ts%
  28.   GEMSYS 77              ! graf_handle
  29.   xchar%=INT{GINTOUT+2}   ! character width
  30.   ychar%=INT{GINTOUT+4}   ! character height
  31.   ~WIND_GET(0,4,wx%,wy%,ww%,wh%)        ! Get work area of the desktop
  32.   ~FORM_DIAL(3,0,0,0,0,wx%,wy%,ww%,wh%) ! Send a redraw message to the desktop
  33.   wx%=ww%/2-xchar%*(pad%/2)-1   ! Set up a default window size and center it
  34.   wy%=wh%/2-ychar%*(10.4)
  35.   ww%=xchar%*(pad%)
  36.   wh%=ychar%*(pad%/2)
  37.   CLEARW #1
  38.   TITLEW #1,"Calendar © Choices"
  39.   OPENW #1,wx%,wy%,ww%,wh%,&X111111111111    ! Open our window
  40.   IF rez%<1
  41.     FULLW #1
  42.   ENDIF
  43.   handle%=W_HAND(#1)
  44. RETURN
  45. > PROCEDURE message                  ! Handle GEM messages
  46.   wx%=MENU(5)   ! intout coordinates
  47.   wy%=MENU(6)
  48.   ww%=MENU(7)
  49.   wh%=MENU(8)
  50.   '
  51.   SELECT MENU(1) ! Get message type
  52.   CASE 20        ! WM_REDRAW
  53.     @redraw
  54.   CASE 21        ! WM_TOPPED
  55.     TOPW #1
  56.   CASE 22        ! WM_CLOSED
  57.     @quit
  58.   CASE 23        ! WM_FULLED
  59.     full%=1-full%  ! Toggle between full and normal
  60.     IF full%
  61.       ox%=wx%      ! If we're going to "full", save old window size
  62.       oy%=wy%
  63.       ow%=ww%
  64.       oh%=wh%
  65.       FULLW #1
  66.     ELSE         ! Otherwise set it back to old size
  67.       ~WIND_SET(handle%,5,ox%,oy%,ow%,oh%)
  68.     ENDIF
  69.   CASE 24
  70.     flag!=FALSE
  71.     SELECT MENU(5)
  72.     CASE 1
  73.       @get_data
  74.       @redraw
  75.     CASE 2
  76.       DEC month%
  77.       IF month%<1
  78.         month%=12
  79.         DEC year%
  80.       ENDIF
  81.       @redraw
  82.     CASE 3
  83.       INC month%
  84.       IF month%>12
  85.         month%=1
  86.         INC year%
  87.       ENDIF
  88.       @redraw
  89.     CASE 6
  90.       DEC year%
  91.       @redraw
  92.     CASE 7
  93.       INC year%
  94.       @redraw
  95.     ENDSELECT
  96.   CASE 27       ! WM_SIZED
  97.     full%=0
  98.     ~WIND_SET(handle%,5,wx%,wy%,MAX(180,ww%),MAX(80,wh%))
  99.   CASE 28       ! WM_MOVED
  100.     full%=0
  101.     ~WIND_SET(handle%,5,wx%,wy%,ww%,wh%)
  102.   ENDSELECT
  103. RETURN
  104. > PROCEDURE mkey                     ! Handle keypresses
  105.   k$=UPPER$(CHR$(MENU(14) AND 255))
  106.   SELECT k$
  107.   CASE " "      ! Spacebar brings up About box
  108.     @about
  109.   CASE "Q",27   ! Q or Esc quits program
  110.     @quit
  111.   ENDSELECT
  112. RETURN
  113. > PROCEDURE about                    ! Tell 'em what we've got, Roy.
  114.   ALERT 1," | Calendar © Choices |  by Roy E. Dean ",1," OK ",b%
  115. RETURN
  116. > PROCEDURE redraw                   ! Walk the rectangle list and do redraws
  117.   ~WIND_UPDATE(1)                  ! Lock out other activity while we redraw
  118.   ~WIND_GET(handle%,11,rx%,ry%,rw%,rh%) ! Get first rectangle in the list
  119.   ~WIND_GET(handle%,4,ax%,ay%,aw%,ah%)  ! Work area of our window
  120.   REPEAT
  121.     IF RC_INTERSECT(ax%,ay%,aw%,ah%,rx%,ry%,rw%,rh%)  ! Find intersection
  122.       CLIP rx%,ry%,rw%,rh% OFFSET ax%,ay%     ! Set clipping to the area in question
  123.       CLEARW #1                         ! Clear the area
  124.       @fillwindow                       ! Call our routine to redraw the area
  125.       CLIP 0,0,WORK_OUT(0),WORK_OUT(1)  ! Reset full-screen clipping
  126.     ENDIF
  127.     ~WIND_GET(handle%,12,rx%,ry%,rw%,rh%) ! Get next rectangle in the list
  128.   UNTIL rw%=0 AND rh%=0                ! Keep repeating until no more rectangles
  129.   ~WIND_UPDATE(0)                    ! Reenable other GEM activity
  130. RETURN
  131. > PROCEDURE fillwindow               ! Redraw sections of our window
  132.   IF year%=1992 AND month%=12
  133.     flag!=TRUE
  134.   ENDIF
  135.   @print_cal
  136. RETURN
  137. > PROCEDURE quit
  138.   ALERT 3," | Do you want to quit? | ",1," Quit | No ",b%
  139.   IF b%=1
  140.     CLOSEW #1
  141.     exit%=TRUE
  142.   ENDIF
  143. RETURN
  144. > PROCEDURE get_data
  145.   rez%=XBIOS(4)
  146.   MODE 0
  147.   exit%=FALSE
  148.   roy$=LEFT$(DATE$,2)
  149.   year$=RIGHT$(DATE$,4)
  150.   year%=VAL(year$)
  151.   month$=MID$(DATE$,4,2)
  152.   month%=VAL(month$)
  153.   flag!=TRUE
  154.   dait$="             1 2 3 4 5 6 7 8 910111213141516171819"
  155.   dait$=dait$+"202122232425262728293031                    "
  156.   daynames$="   Sun    Mon    Tue    Wed    Thu  "
  157.   daynames$=daynames$+"   Fri   Sat"
  158.   monthname$="January  February March    April    May      June     July   "
  159.   monthname$=monthname$+"  August   SeptemberOctober  November December "
  160.   monthdays$="312831303130313130313031"
  161. RETURN
  162. > PROCEDURE print_cal
  163.   FOR mb%=1 TO month%
  164.     mc%=mb%
  165.     yc%=year%
  166.     @calendar_day_of_week
  167.     w1%=weekday%
  168.     mc%=mb%
  169.     month1$=MID$(monthname$,(mc%-1)*9+1,9)
  170.     IF mb%>=month%
  171.       CLS
  172.       PRINT
  173.       PRINT SPC(LEN(daynames$)*(pad%/100));month1$;" ";year%
  174.       PRINT
  175.       PRINT daynames$
  176.       PRINT
  177.       PRINT
  178.     ENDIF
  179.     mc%=mb%
  180.     @days_in_month
  181.     d1%=dm%
  182.     FOR i%=1 TO 6
  183.       j%=1
  184.       IF i%>4 AND ((i%-1)*7+j%)>d1%+w1%
  185.       ELSE
  186.         IF mb%=>month%
  187.           @weeks
  188.           PRINT
  189.           PRINT
  190.           PRINT
  191.         ENDIF
  192.       ENDIF
  193.     NEXT i%
  194.   NEXT mb%
  195. RETURN
  196. > PROCEDURE calendar_day_of_week
  197.   IF mc%<3
  198.     ADD mc%,12
  199.     DEC yc%
  200.   ENDIF
  201.   weekday%=1+2*mc%+INT(0.6*(mc%+1))+yc%+INT(yc%/4)-INT(yc%/100)+INT(yc%/400)+2
  202.   weekday%=weekday%-INT(weekday%/7)*7
  203.   weekday%=weekday%+6
  204.   weekday%=weekday%-INT(weekday%/7)*7
  205. RETURN
  206. > PROCEDURE days_in_month
  207.   IF mc%=2
  208.     IF INT(year%/4)=year%/4
  209.       MID$(monthdays$,2*mc%,1)="9"
  210.     ENDIF
  211.     IF INT(year%/4)<>year%/4
  212.       MID$(monthdays$,2*mc%,1)="8"
  213.     ENDIF
  214.   ENDIF
  215.   dm%=VAL(MID$(monthdays$,2*mc%-1,2))
  216. RETURN
  217. > PROCEDURE weeks
  218.   FOR j%=1 TO 7
  219.     e1%=((i%-1)*7+j%+6-w1%)*2-1
  220.     IF ((i%-1)*7+j%)>(d1%+w1%)
  221.       day$="__"
  222.     ELSE
  223.       day$=MID$(dait$,e1%,2)
  224.     ENDIF
  225.     IF roy$=day$ AND flag!
  226.       DEFTEXT 3,1,0,ts%
  227.     ENDIF
  228.     PRINT "   ";day$;"  ";
  229.     DEFTEXT 1,1,0,ts%
  230.   NEXT j%
  231. RETURN
  232.