!  ***********************************************
!  ** (c) Interactive Software Services Ltd and **
!  **     Lahey Computer Systems Inc. 1997-2002 **
!  ** ----------------------------------------- **
!  ** 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
!
      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_STYLE)    :: WINDOW
      TYPE(WIN_MESSAGE)  :: MESSAGE
      CHARACTER(LEN=40)  :: VALUE
      LOGICAL            :: NEW
      INTEGER            :: MAXITR,MAXPTS,ITYPE
!
      INTERFACE
        SUBROUTINE FRACT(NEW,MAXPTS,MAXITR)
          IMPLICIT NONE
          LOGICAL, INTENT (IN OUT) :: NEW
          INTEGER, INTENT (IN    ) :: MAXPTS,MAXITR
        END SUBROUTINE FRACT
      END INTERFACE
!
!  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.)
!
!  reseed the random number generator using
!  the number of seconds past the hour
!
      CALL random_seed()
      NEW = .TRUE.
!
!  Ask user for number of points/iterations
!
      CALL WDialogLoad(IDD_DIALOG01)
      CALL WDialogShow(ITYPE=Modal)
      IF (WInfoDialog(ExitButton)==IDOK) THEN
!
!  Retrieve number of points per iteration and maximum iterations per plot
!
          CALL WDialogGetString(IDF_MAXPTS,VALUE)
          CALL IStringToInteger(VALUE,MAXPTS)
          CALL WDialogGetString(IDF_MAXITR,VALUE)
          CALL IStringToInteger(VALUE,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)
                    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
      END PROGRAM FRACPAT
!
      SUBROUTINE FRACT(NEW,MAXPTS,MAXITR)
!
!  Generate a fractal pattern.
!
!  Increase MAXPTS/MAXITR for larger, more complex patterns.
!  Reduce   MAXPTS/MAXITR for simpler/faster plots
!
      USE WINTERACTER
!
      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
      REAL                 :: RAND, XNEW
      INTEGER              :: NPTS
      CHARACTER(LEN=5)     :: SITER
!
!  Start a new pattern ?
!
      IF (NEW) THEN
          CALL random_number(RAND)
          SA   = RAND * 100. - 50.
          CALL random_number(RAND)
          SB   = RAND * 100. - 50.
          CALL random_number(RAND)
          SC   = RAND * 100. - 50.
          S    = 1.2 * (6.0 - (ABS(SA)+ABS(SB)+ABS(SC))/30.)
          XOLD = 0.0
          Y    = 0.0
          ITER = 1
!
!  Calculate random centre of pattern
!
          CALL random_number(RAND)
          CENTRX = 256 + RAND*512.
          CALL random_number(RAND)
          CENTRY = 192 + RAND*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(RAND)
      IF (RAND==0.0) RAND = 0.5
      CALL IGrColourN(INT(RAND*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, start new plot next time in
!
      NEW = ITER==MAXITR
      RETURN
      END SUBROUTINE FRACT