home *** CD-ROM | disk | FTP | other *** search
/ GEMini Atari / GEMini_Atari_CD-ROM_Walnut_Creek_December_1993.iso / files / acc / calendar / calndr / cal.lst < prev    next >
Encoding:
File List  |  1992-12-22  |  5.9 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.