home *** CD-ROM | disk | FTP | other *** search
/ Vectronix 2 / VECTRONIX2.iso / FILES_01 / P_FOTRAN.LZH / DEMOS.FOR / CLOCKDA.FOR < prev    next >
Text File  |  1987-12-31  |  7KB  |  199 lines
  1. *--------------------------------------------------------------------*
  2. *   A sample desk accessory for Prospero Fortran                     *
  3. *   This accessory displays an analogue clock face                   *
  4. *                                                                    *
  5. *   Do NOT run CLOCKDA.PRG from the Workbench or the GEM Desktop -   *
  6. *   once linked it should be renamed CLOCKDA.ACC, and copied to a    *
  7. *   boot disk. Next time the Atari is booted using that disk, this   *
  8. *   accessory will install itself, and can be run by selecting the   *
  9. *   item "Analog clock" from the Desk menu                           *
  10. *                                                                    *
  11. *   See also the note in READ.ME about debugging Desk accessories    *
  12. *                                                                    *
  13. *   Author: R K Chapman                                              *
  14. *   Date  : 28 August 1987                                           *
  15. *--------------------------------------------------------------------*
  16.  
  17.       PROGRAM clockda
  18.  
  19.       IMPLICIT none
  20.       INTEGER*4 ap_id, m_id
  21.       INTEGER*2 work_in(0:10), work_out(0:56), message(0:7)
  22.       CHARACTER*20 my_menu_item        ! must be in a variable
  23.       CHARACTER*10 my_window_title     ! ditto
  24.       INTEGER*4 cx, cy, cw, ch         ! Window's total area
  25.       LOGICAL*1 on_screen              ! is the window open ?
  26.       INTEGER*4 event, events
  27.       INTEGER*4 i, dummy
  28.  
  29.       COMMON    /workstation/ my_window, workstation, aspect,
  30.      -                        wx, wy, ww, wh
  31.       INTEGER*4 my_window              ! Window handle
  32.       INTEGER*4 workstation            ! Workstation handle
  33.       INTEGER*4 wx, wy, ww, wh         ! Window's work area
  34.       REAL*4    aspect
  35.   
  36.       INCLUDE 'GEMFUNCS'
  37.       INCLUDE 'GEMCONST'
  38.  
  39.       CALL appl_init
  40.       ap_id = AESret()
  41.       workstation = graf_handle(dummy, dummy, dummy, dummy)
  42.       DO 10 i = 0, 8
  43. 10      work_in(i) = 1
  44.       work_in(9) = 0             ! fill colour is 0 (white)
  45.       work_in(10) = 2            ! raster coords
  46.       CALL v_opnvwk(work_in, workstation, work_out)
  47.       aspect = float(work_out(3))/work_out(4)
  48.       my_menu_item = '  Analog clock'//char(0)
  49.       m_id = menu_register(ap_id, my_menu_item)
  50.       events = MU_MESAG
  51.       on_screen = .false.
  52.       cx = 20
  53.       cy = 40
  54.       cw = 100
  55.       ch = nint(100*aspect) ! Initial window work area position/size
  56.       CALL wind_calc(.false., NAME .OR. CLOSER .OR. MOVER,
  57.      -               cx, cy, cw, ch, cx, cy, cw, ch)
  58. 20    CONTINUE
  59.         event = evnt_multi(events,
  60.      -                     1, 1, 1,
  61.      -                     .false., 0, 0, 0, 0,
  62.      -                     .false., 0, 0, 0, 0,
  63.      -                     message, 1950,
  64.      -                     dummy, dummy, dummy, dummy, dummy, dummy)
  65.         IF ((event .AND. MU_MESAG) .ne. 0) THEN
  66.  
  67.           IF ((message(0) .eq. WM_TOPPED) .OR.
  68.      -        (message(0) .eq. AC_OPEN)) THEN
  69.             IF (on_screen) THEN
  70. *             Move window to top
  71.               CALL wind_set(my_window, WF_TOP, 0, 0, 0, 0)
  72.               CALL graf_mouse(0, 0)
  73.             ELSE
  74. *             Open a window
  75.               CALL graf_mouse(0, 0)
  76.               my_window = wind_create(CLOSER .OR. NAME .OR. MOVER,
  77.      -                                cx, cy, cw, ch)
  78.               IF (my_window .gt. 0) THEN
  79.                 my_window_title = 'Clock'//char(0)
  80.                 CALL wind_title(my_window, my_window_title)
  81.                 CALL wind_open(my_window, cx, cy, cw, ch)
  82.                 CALL wind_get(my_window, WF_WXYWH, wx, wy, ww, wh)
  83.                 on_screen = .true.
  84.               END IF  
  85.             END IF
  86.  
  87.           ELSE IF (message(0) .eq. AC_CLOSE) THEN
  88. *           window handle no longer valid
  89.             on_screen = .false.
  90.  
  91.           ELSE IF (message(0) .eq. WM_CLOSED) THEN
  92.             IF (on_screen) THEN
  93. *             Close window
  94.               CALL wind_close(my_window)
  95.               CALL wind_delete(my_window)
  96.               on_screen = .false.
  97.             END IF
  98.  
  99.           ELSE IF (message(0) .eq. WM_MOVED) THEN
  100. *           Move the window
  101.             IF (message(3) .eq. my_window) THEN
  102.               cx = message(4)
  103.               cy = message(5)
  104.               cw = message(6)
  105.               ch = message(7)
  106.               CALL wind_set(my_window, WF_CXYWH,
  107.      -                      cx, cy, cw, ch)
  108.               CALL wind_get(my_window, WF_WXYWH,
  109.      -                      wx, wy, ww, wh)
  110.             END IF
  111.  
  112.           ELSE IF (message(0) .eq. WM_REDRAW) THEN
  113.             IF (message(3) .eq. my_window) CALL redraw
  114.           END IF
  115.         END IF
  116.  
  117.         IF ((events .AND. MU_TIMER) .ne. 0) THEN
  118.           IF (on_screen) CALL redraw
  119.         END IF
  120.  
  121.         IF (on_screen) THEN
  122.           events = MU_TIMER .OR. MU_MESAG
  123.         ELSE
  124.           events = MU_MESAG
  125.         END IF
  126.  
  127.       GOTO 20                           ! Repeat indefinitely
  128.       END
  129.  
  130. *-------------------------------------------------------------
  131. *  redraw draws the clock face to the visible portion of the 
  132. *  window
  133. *-------------------------------------------------------------
  134.  
  135.       SUBROUTINE redraw
  136.       IMPLICIT none
  137.       INTEGER*2 rect(0:3)
  138.       INTEGER*4 rx, ry, rw, rh
  139.       INTEGER*4 hours, mins, secs, huns
  140.  
  141.       COMMON    /workstation/ my_window, workstation, aspect,
  142.      -                        wx, wy, ww, wh
  143.       INTEGER*4 my_window, workstation, wx, wy, ww, wh
  144.       REAL*4    aspect
  145.  
  146.       INCLUDE 'GEMCONST'
  147.   
  148.       CALL wind_update(beg_update)
  149.       CALL wind_get(my_window, WF_FIRSTXYWH, rx, ry, rw, rh)
  150. 10    CONTINUE
  151.       IF (rw+rh .ne. 0) THEN
  152.         rect(0) = rx
  153.         rect(1) = ry
  154.         rect(2) = rx+rw-1
  155.         rect(3) = ry+rh-1
  156.         CALL vs_clip(workstation, .true., rect)
  157.         CALL time(hours, mins, secs, huns)
  158.         CALL graf_mouse(256, 0)                ! hide mouse
  159.         CALL vr_recfl(workstation, rect)
  160.         CALL v_arc(workstation, wx + ww/2, wy + wh/2, ww/2, 0, 3600)
  161.         rect(0) = wx + ww/2
  162.         rect(1) = wy + wh/2
  163.         CALL plot_polar(rect, mod(hours, 12)*300 + mins*5, 30)
  164.         CALL plot_polar(rect, mins*60 + secs, 40)
  165.         CALL plot_polar(rect, secs*60, 50)
  166.         CALL graf_mouse(257, 0)                ! Show mouse
  167.         CALL wind_get(my_window, WF_NEXTXYWH, rx, ry, rw, rh)
  168.         GOTO 10
  169.       END IF
  170.       CALL wind_update(end_update)
  171.       END
  172.  
  173. *---------------------------------------------------------
  174. *  plot_polar draws a line from the cetre of the window's
  175. *  work area, with the given angle and length
  176. *---------------------------------------------------------
  177.  
  178.       SUBROUTINE plot_polar(rect, angle, radius)
  179.       IMPLICIT none
  180.       INTEGER*4 angle, radius
  181.       INTEGER*2 rect(0:3)
  182.       REAL*4 rangle
  183.  
  184.       COMMON    /workstation/ my_window, workstation, aspect,
  185.      -                        wx, wy, ww, wh
  186.       INTEGER*4 my_window, workstation, wx, wy, ww, wh
  187.       REAL*4    aspect
  188.   
  189.       angle = 900 - angle
  190.       IF (angle .lt. 0) angle = angle+3600
  191.       rangle = angle * 3.1415927/1800
  192.       rect(2) = rect(0) + nint(radius*cos(rangle))
  193.       rect(3) = rect(1) - nint(radius*sin(rangle)*aspect)
  194.       CALL v_pline(workstation, 2, rect)
  195.       END
  196.     
  197.  
  198.  
  199.