Demonic Noodles

dnoodles.f

* Demonic Noodles
*
* Author:      Maciej Konieczny <[email protected]>
* Website:     http://gist.github.com/639250
* License:     public domain <http://unlicense.org/>
* Background:  My first Fortran program; written as a Programming
*              Paradigms assignment.  We were supposed to generate
*              a creature picture in Fortran 77.


      PROGRAM DNOODLES

*     define variables with non-implicit type
      CHARACTER PATH*12
      INTEGER SEED

*     treat FILE_ID and CANVAS_SIZE as globals
      COMMON /GLOBALS/ FILE_ID, CANVAS_SIZE
      INTEGER FILE_ID
      INTEGER CANVAS_SIZE
      SAVE /GLOBALS/

*     set random seed
      SEED = 0

*     set canvas size in pixels (it will be square)
      CANVAS_SIZE = 640

*     set helpful values
      TWOPI = 710.0 / 113.0
      DEG = TWOPI / 360.0

*     (create and) open file
      PATH = 'dnoodles.svg'
      FILE_ID = 0
      OPEN(FILE_ID, FILE=PATH)

*     begin drawing
      CALL BEGIN_SVG

*     draw lots of noodles
      R1 = 10.0
      R2 = 40.0
      DO I = 1, 200
*         choose point inside circle of radius R1
          TEMP_ANGLE = TWOPI * RAN(SEED)
          TEMP_R = R1 * RAN(SEED)
          X1 = 50.0 + TEMP_R * COS(TEMP_ANGLE)
          Y1 = 50.0 + TEMP_R * SIN(TEMP_ANGLE)

*         do random stuff :)
          ANGLE = TWOPI * RAN(SEED)
          TEMP_R = 0.3 * R2
          X2 = X1 + TEMP_R * COS(ANGLE)
          Y2 = Y1 + TEMP_R * SIN(ANGLE)

          TEMP_ANGLE = ANGLE + 30.0 * DEG * 2.0 * (RAN(SEED) - 0.5)
          TEMP_R = 0.6 * R2
          X3 = X1 + TEMP_R * COS(TEMP_ANGLE)
          Y3 = Y1 + TEMP_R * SIN(TEMP_ANGLE)

          TEMP_ANGLE = ANGLE + 30.0 * DEG * 2.0 * (RAN(SEED) - 0.5)
          X4 = X1 + R2 * COS(TEMP_ANGLE)
          Y4 = Y1 + R2 * SIN(TEMP_ANGLE)

*         choose width between 1.3 and 2.0
          WIDTH = 1.3 + 0.7 * RAN(SEED)

*         draw noodle
          CALL DRAW_CURVE(X1, Y1, X2, Y2, X3, Y3, X4, Y4, WIDTH)
      END DO

*     draw left eye
      CALL DRAW_CIRCLE(46.0, 43.0, 3.5)
      CALL DRAW_CIRCLE(46.3, 43.3, 0.3)

*     draw right eye
      CALL DRAW_CIRCLE(54.0, 43.0, 3.3)
      CALL DRAW_CIRCLE(53.7, 43.3, 0.3)

*     finish drawing
      CALL FINISH_SVG

*     close file
      CLOSE(FILE_ID)

*     show info
      WRITE(*, '(A, A)') 'Picture saved to ', PATH
      END


*----------------------------- subroutines -----------------------------

* write initial svg stuff
      SUBROUTINE BEGIN_SVG
      COMMON /GLOBALS/ FILE_ID
      INTEGER FILE_ID
      WRITE(FILE_ID, '(A, $)') '<?xml version="1.0"?>\n<!DOCTYPE svg PUB
     $LIC "-//W3C//DTD SVG 1.1//EN" "http://www.w3.org/Graphics/SVG/1.1/
     $DTD/svg11.dtd">\n<svg width="'
      CALL WRITE_POSITION(100.0)
      WRITE(FILE_ID, '(A, $)') '" height="'
      CALL WRITE_POSITION(100.0)
      WRITE(FILE_ID, '(A)') '" version="1.1" xmlns="http://www.w3.org/20
     $00/svg">'
      END

* draw circle
      SUBROUTINE DRAW_CIRCLE(X, Y, R)
      COMMON /GLOBALS/ FILE_ID
      INTEGER FILE_ID
      WRITE(FILE_ID, '(A, $)') '<circle cx="'
      CALL WRITE_POSITION(X)
      WRITE(FILE_ID, '(A, $)') '" cy="'
      CALL WRITE_POSITION(Y)
      WRITE(FILE_ID, '(A, $)') '" r="'
      CALL WRITE_POSITION(R)
      WRITE(FILE_ID, '(A, $)') '" fill="white" stroke="black" stroke-wid
     $th="'
      CALL WRITE_POSITION(0.4)
      WRITE(FILE_ID, '(A)') '"/>'
      END

* draw quadratic bezier curve
      SUBROUTINE DRAW_CURVE(X1, Y1, X2, Y2, X3, Y3, X4, Y4, WIDTH)
      CALL DRAW_CURVE_(X1, Y1, X2, Y2, X3, Y3, X4, Y4, WIDTH, 'black')
      CALL DRAW_CURVE_(X1, Y1, X2, Y2, X3, Y3, X4, Y4, WIDTH - 0.8, 'whi
     $te')
      END

      SUBROUTINE DRAW_CURVE_(X1, Y1, X2, Y2, X3, Y3, X4, Y4, W, C)
      COMMON /GLOBALS/ FILE_ID
      INTEGER FILE_ID
      CHARACTER C*5
      WRITE(FILE_ID, '(A, $)') '<path d="M '
      CALL WRITE_POSITION(X1)
      WRITE(FILE_ID, '(A, $)') ' '
      CALL WRITE_POSITION(Y1)
      WRITE(FILE_ID, '(A, $)') ' Q '
      CALL WRITE_POSITION(X2)
      WRITE(FILE_ID, '(A, $)') ' '
      CALL WRITE_POSITION(Y2)
      WRITE(FILE_ID, '(A, $)') ' '
      CALL WRITE_POSITION(X3)
      WRITE(FILE_ID, '(A, $)') ' '
      CALL WRITE_POSITION(Y3)
      WRITE(FILE_ID, '(A, $)') ' T '
      CALL WRITE_POSITION(X4)
      WRITE(FILE_ID, '(A, $)') ' '
      CALL WRITE_POSITION(Y4)
      WRITE(FILE_ID, '(A, A, A, $)') '" fill="none" stroke="', C, '" str
     $oke-width="'
      CALL WRITE_POSITION(W)
      WRITE(FILE_ID, '(A)') '" stroke-linecap="round" />'
      END

* write final svg stuff
      SUBROUTINE FINISH_SVG
      COMMON /GLOBALS/ FILE_ID
      INTEGER FILE_ID
      WRITE(FILE_ID, '(A)') '</svg>'
      END

* write position (in pixels) given relative (percent) value
*
* write a number with two decimal places and *nothing* more (no initial
* nor trailing whitespace)
      SUBROUTINE WRITE_POSITION(RELATIVE)
      COMMON /GLOBALS/ FILE_ID, CANVAS_SIZE
      INTEGER FILE_ID
      INTEGER CANVAS_SIZE

      ABSOLUTE = CANVAS_SIZE * RELATIVE / 100.0

*     (this madness...)
      IF (ABSOLUTE .LT. 10.0) THEN
          WRITE(FILE_ID, '(F4.2, $)') ABSOLUTE
      ELSE
          IF (ABSOLUTE .LT. 100.0) THEN
              WRITE(FILE_ID, '(F5.2, $)') ABSOLUTE
          ELSE
              WRITE(FILE_ID, '(F6.2, $)') ABSOLUTE
          END IF
      END IF
      END

dnoodles.md