Skip to content

Instantly share code, notes, and snippets.

@narfdotpl
Created October 21, 2010 20:17
Show Gist options
  • Save narfdotpl/639250 to your computer and use it in GitHub Desktop.
Save narfdotpl/639250 to your computer and use it in GitHub Desktop.
Demonic Noodles
* Demonic Noodles
*
* Author: Maciej Konieczny <hello@narf.pl>
* 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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment