Conference rusure::math

152.0. "Turtle curves" by NOVA::KLEIN () Wed Sep 19 1984 15:16

	program turtle

c Modified Jim Ravan's Fractal program to write "turtle" curves.
c Based on Scientific American, February 1984 - Computer Recreations
c by Brian Hayes, pages 14- 20
c
c		Steve Klein

	real*8 angle,theta,angled,thetad,angle00,pi,twopi
	real*8 x0,y0,x1,y1,x00,y00,delta
	integer*4 ipoints,n,d,iclear,xi,yi
	character*1 esc,cc
	common esc,cc

C	Initial default parameter values.

	delta = .1
	pi = 3.14159265358979
	twopi = pi * 2.0
	ipoints = 99999
	xi = 767 / 2
	yi = 480 / 2
	angled = 90
	thetad = 37
	iclear = 1
	d = 17

C	Clear screen to begin.

	cc = '+'
	esc = char(27)
	call clear

C	Initial reminder.

	call lib$erase_line(24,1)
	call lib$put_line(
	1'ctrl-z to any prompt stops the program.',0)

C	Get parameters.

10	ipoints = igetval('segment count',ipoints)
	angled = getval('initial angle in degrees',angled)
	thetad = getval('incremental angle in degrees',thetad)
	delta = getval('cycle detect angle in radians',delta)
	xi = igetval('X0',xi)
	yi = igetval('Y0',yi)
	d = igetval('vector length in pixels',d)
	iclear = igetyn('clear the screen?',iclear)

	angle = angled / 360. * twopi
	theta = thetad / 360. * twopi
	x0 = xi
	y0 = yi

D	iplot = igetyn('plot?',1)
D	if (iplot .eq. 2) then
D	    cc = ' '
D	    esc = char(32)
D	endif

	goto (30,10),igetyn('Continue? (no = reprompt)',1)

30	call lib$erase_line(1,1)
	call lib$erase_line(24,1)

C	Clear the screen, if necessary.

	if (iclear .eq. 1) call clear

C	Position for the first point.

	write (6,11) cc,esc,ifix(sngl(x0)),ifix(sngl(y0))
11	format (A1,A1,'PpP[',I3,',',I3,']',$)

C	main loop. do all the points.

	x00 = x0
	y00 = y0
	angle00 = angle
	l = 1
	do 200 j = 0,ipoints-1

C	Check for cycles.

	if (mod(abs(angle-angle00),twopi).lt.delta
	1	.and.abs(x0-x00).lt.3
	1	.and.abs(y0-y00).lt.3.and.j.ne.0) goto 299

	angle = theta * j + angle
	x1 = x0 + dcos(angle) * d
	y1 = y0 - dsin(angle) * d

C	If not out-of-bounds, plot vector.

	if (x1.gt.999.or.x1.lt.-99.or.y1.gt.999.or.y1.lt.-99)
	1	goto 111

C	Occasionally force newline to keep terminal driver happy.

	if (mod(l,16).ne.0) goto 120
	write (6,13) cc,esc,esc
13	format (A1,A1,'\',a1,'[H',$)
	write (6,15)
15	format (' ')
	write (6,14) cc,esc
14	format (A1,A1,'Pp',$)
120	continue
	l = l + 1

	write (6,12) cc,ifix(sngl(x1+.5)),ifix(sngl(y1+.5))
12	format(A1,'V[',I3,',',I3,']',$)
111	continue

	x0 = x1
	y0 = y1

200	continue
299	continue

C	Ask to do another.
	write (6,13) esc,esc

	goto (10,999),igetyn('Another?',1)

999	call lib$erase_line(1,1)
	call lib$erase_line(24,1)
	call exit
	end

	real function getval(prompt,defval)

	character*(*) prompt
	character*80 response
	integer*4 type

	type = 1
	goto 5

	entry igetval(prompt,idefval)

	type = 2

5	if (type .eq. 1) then
	    write (response,10) prompt,defval
	else
	    write (response,11) prompt,idefval
	endif
10	format(A,' [',F6.2,'] = ')
11	format(A,' [',I10,'] = ')
	call lib$erase_line(1,1)
	call lib$put_line(response,0)
	call lib$set_cursor(1,itrim(response)+2)
	read (5,15,end=999) n,response
15	format (Q,A80)

C	If there is no response, supply the default value.

	if (n .eq. 0) then
	    if (type .eq. 1) then
		getval = defval
	    else
		igetval = idefval
	    endif

C	If there is a response, provide a trailing decimal point, if necessary,
C	then convert the response to a floating point number, or properly
C	convert the integer, if this is a call to igetval.

	else
	    if (type .eq. 1) then
		if (lib$locc('.',response) .eq. 0) then
		    response(n+1:n+1) = '.'
		endif
		read (response,20) getval
20	        format(F10.5)
	    else
		read (response,21) igetval
21	        format(I<n>)
	    endif
	endif

	return

999	call lib$erase_line(1,1)
	call lib$erase_line(24,1)
	call exit
	end

	integer function igetyn(prompt,idefault)

	character*(*) prompt
	character*80 answer
	character*6 yes,no,which
	data yes/'[yes]:'/,no/'[no]: '/

2	if (idefault .eq. 1) then
	    which = yes
	else
	    which = no
	endif
	write (answer,5) prompt,which
5	format(A,' ',A)
	call lib$erase_line(1,1)
	call lib$put_line(answer,0)
	call lib$set_cursor(1,itrim(answer)+2)
	read (5,9005,end=8999) i,answer
	if (i.eq.0) goto 7
	if (answer(1:1).eq.'y'.or.answer(1:1).eq.'Y') goto 20
	if (answer(1:1).eq.'n'.or.answer(1:1).eq.'N') goto 10
	goto 2

C	Provide the default answer.

7	igetyn = idefault
	goto 30

C	The explicit answer is 'NO'

10	igetyn = 2
	goto 30

C	The explicit answer is 'YES'

20	igetyn = 1
30	return

8999	call lib$erase_line(1,1)
	call lib$erase_line(24,1)
	call exit

C Format statements

9005	format (Q,A)

	end

	integer function itrim(string)
	character*(*) string

C This function returns the length of the input string with
C trailing ' ' characters removed.
C If the string contains only ' ' characters, 1 will be returned.

	do 10 i = 1,len(string)
	j = len(string) - i + 1
	if (string(j:j) .ne. ' ') goto 20
10	continue

20	itrim = j
	return
	end

	subroutine clear

	integer*4 nseed1,nseed2
	character*1 esc,cc

	common esc,cc

	write (6,10) cc,esc,esc,esc,esc
10	format(A1,A1,'[H',A1,'[2J',A1,
	1'P1pS(M0(L0)(AL0))S(I0)S(E)S[0,0]',A1,'\')

	return
	end

    I build this program, and run it, givving it default values, and
    nothing happens? I wanted to see this turtle real bad.
    /naser