!  ***********************************************
!  ** (c) Interactive Software Services Ltd and **
!  **     Lahey Computer Systems Inc. 1997-2011 **
!  ** ----------------------------------------- **
!  ** This demonstration program source may be  **
!  ** modified for training and for product     **
!  ** familiarisation.                          **
!  ** ----------------------------------------- **
!  ** Purpose : Generate fractal patterns       **
!  ***********************************************
!
!  This program generates random fractal patterns using the
!  subroutine FRACT which repeatedly plots single points
!  in various colours using the Winteracter routine IGrPoint.
!
!  FRACPAT is derived from routines written by Norman Clerman of
!  Opcon Associates, Ohio, USA. Norman's code was in turn based on a
!  Pascal program written by Alan Meiss. Both sources are acknowledged.
!
      PROGRAM FRACPAT
!
      USE WINTERACTER
      IMPLICIT NONE
!
!  Resource identifiers, as set via the resource editor
!
      INTEGER, PARAMETER :: IDR_MENU1                       = 30001
      INTEGER, PARAMETER :: ID_NEW                          = 40001
      INTEGER, PARAMETER :: ID_EXIT                         = 40002
      INTEGER, PARAMETER :: IDD_DIALOG01                    =   101
      INTEGER, PARAMETER :: IDF_MAXPTS                      =  1003
      INTEGER, PARAMETER :: IDF_MAXITR                      =  1004
!
      TYPE(WIN_MESSAGE)  :: MESSAGE
      LOGICAL            :: NEW
      INTEGER            :: ITYPE,MAXPTS,MAXITR
!
!  Initialise Winteracter
!
      CALL WInitialise()
!
!  Open root window
!
      CALL WindowOpen(FLAGS =SysMenuOn+MinButton+MaxButton+StatusBar, &
                      MENUID=IDR_MENU1,                               &
                      TITLE ='Fractal Patterns')
!
!  Split status bar into 2.
!  Use first part to display Iteration label, without border.
!
      CALL WindowStatusBarParts(2,(/1000,800/),(/BorderNone,BorderSunken/))
      CALL WindowOutStatusBar(1,'Iteration')
!
!  Declare an arbitrary co-ordinate system
!
      CALL IGrUnits(0.,0.,1024.,768.)
!
      NEW = .TRUE.
!
!  Ask user for number of points/iterations
!
      CALL WDialogLoad(IDD_DIALOG01)
      CALL WDialogSpinnerStep(IDF_MAXPTS,25)
      CALL WDialogSpinnerStep(IDF_MAXITR,25)
      CALL WDialogShow(ITYPE=Modal)
      IF (WInfoDialog(ExitButton)==IDOK) THEN
!
!  Retrieve number of points per iteration and maximum iterations per plot
!
          CALL WDialogGetInteger(IDF_MAXPTS,MAXPTS)
          CALL WDialogGetInteger(IDF_MAXITR,MAXITR)
!
!  Loop forever until user terminates
!
          DO
!
!  Plot next iteration or start a new pattern
!
            CALL FRACT(NEW,MAXPTS,MAXITR)
!
!  Get message from queue, if available
!
            CALL WMessagePeek(ITYPE, MESSAGE)
!
            SELECT CASE (ITYPE)
!
!  Menu item message
!
              CASE (MenuSelect)
                SELECT CASE (MESSAGE%VALUE1)
!
!  New plot
!
                  CASE (ID_NEW)
                    CALL WDialogShow(ITYPE=Modal)
                    IF (WInfoDialog(ExitButton)==IDOK) THEN
                        CALL WDialogGetInteger(IDF_MAXPTS,MAXPTS)
                        CALL WDialogGetInteger(IDF_MAXITR,MAXITR)
                    END IF
                    NEW = .TRUE.
!
!  Exit program
!
                  CASE (ID_EXIT)
                    EXIT
                END SELECT
!
!  Start a new plot if we get an expose or resize event
!
              CASE (Expose,Resize)
                NEW = .TRUE.
!
!  Close window
!
              CASE (CloseRequest)
                EXIT
            END SELECT
          END DO
      END IF
!
      CALL WindowClose()
      STOP
!
      CONTAINS
!
      SUBROUTINE FRACT(NEW,MAXPTS,MAXITR)
!
!  Generate a fractal pattern.
!
!  Increase MAXPTS/MAXITR for larger, more complex patterns.
!  Reduce   MAXPTS/MAXITR for simpler/faster plots
!
      IMPLICIT NONE
      LOGICAL, INTENT (IN OUT) :: NEW
      INTEGER, INTENT (IN)     :: MAXPTS,MAXITR
!
      REAL   , SAVE            :: SA,SB,SC,S,XOLD,Y,CENTRX,CENTRY
      INTEGER, SAVE            :: ITER
!
      CHARACTER(LEN=5)         :: SITER
      INTEGER                  :: NPTS
      REAL                     :: XNEW,RCOL
!
!  Start a new pattern ?
!
      IF (NEW) THEN
          CALL RANDOM_NUMBER(SA)
          CALL RANDOM_NUMBER(SB)
          CALL RANDOM_NUMBER(SC)
          SA   = SA*100. - 50.
          SB   = SB*100. - 50.
          SC   = SC*100. - 50.
          S    = 1.2 * (6.0 - (ABS(SA)+ABS(SB)+ABS(SC))/30.)
          XOLD = 0.0
          Y    = 0.0
          ITER = 1
          CALL WindowOutStatusBar(2,'')
!
!  Calculate random centre of pattern
!
          CALL RANDOM_NUMBER(CENTRX)
          CALL RANDOM_NUMBER(CENTRY)
          CENTRX = 256 + CENTRX*512.
          CENTRY = 192 + CENTRY*384.
!
!  Clear graphics area
!
          CALL IGrAreaClear()
      END IF
!
!  New iteration : Choose random colour
!
      ITER = ITER + 1
      IF (MOD(ITER,50)==0) THEN
          CALL IntegerToString(ITER,SITER,'(I5)')
          CALL WindowOutStatusBar(2,SITER)
      END IF
      CALL RANDOM_NUMBER(RCOL)
      CALL IGrColourN(INT(RCOL*255.))
!
!  Plot MAXPTS points
!
      DO NPTS = 1,MAXPTS
          CALL IGrPoint(XOLD*S+CENTRX,Y*S+CENTRY)
          XNEW = Y  - SIGN(1.,XOLD)*SQRT(ABS(SB*XOLD-SC))
          Y    = SA - XOLD
          XOLD = XNEW
      END DO
!
!  Max iterations reached ? If so, start new plot next time in
!
      NEW = ITER.EQ.MAXITR
      RETURN
      END SUBROUTINE FRACT
!
      END PROGRAM FRACPAT