⟦cb32aa9d6⟧

TextFile

**********************************************************************
*
* subroutine makemov(x1,y1) does the following:
*  (make a move)
*    + ask user to input one point coords within
*      bounds
*    + read point position
*    + check if point within bounds
*      - yes->
*             * move to point
*      - no->
*             * error- incorrect value
*                      try again
*********************************************************************
	subroutine makemov(x1,y1)
c
	real x1,y1
c
	do 27 i=1,4
	write(0,17)
17	format(5x,'specify point coords,x&y>=0.0 & <=10.0',
     *  /,5x,'like this:2.5 blank 2.0')
c
	read(5,*)x1,y1
	if(x1.lt.0.0 .or. x1.gt.10.0 .or. y1.lt.0.0 .or. 
     *     y1.gt.10.0)then
	                  call error(2)
	else
	                  i=5
	endif
27	continue
	call move(x1,y1)
	return
	end
***************************************************************************
*
* subroutine lcmenu does the following:
*  (local change menu--item editing menu)
*   
*    + In the process of creating an item
*      this menu is displayed to enable the
*      user to use its commands to make
*      changes on current item.
*    + commands are:
*  
*      p - position(to change current item position)
*      c - color(to change current item color)
*      m - measurment(to change current item
*          measurment).
*                                      + display local change menu to
*                                      be able to pick a command to 
*                                      do some changes while user
*                                      engaged in drawing an item.
************************************************************************
	subroutine lcmenu
	write(0,10)
10	format(5x,'elements to be changed are:',
     *  /,5x,'p - position',/,5x,'For items (Square,Triangle,Rectangle',
     *  /,5x,'and Line) it is bottom left corner point',
     *  /,5x,'For (Circle) it is center coords',/,5x,'c - color',/,5x,
     *  'm - measurment ')
	return
	end


************************************************************************
*
* subroutine clrmenu does the following:
* (color menu)
*    + display the color menu like this 
*     0 - black
*     1 - red
*     2 - green
*     3 - yellow
*     4 - blue
*     5 - magenta
*     6 - cyan
*     7 - white
*     8 - grey
*     9 - orange
*     10 - l. brown
*     11 - brown
*     12 - sky blue
*     13 - violet
*     14 - turqoise
*     15 - dark green
*************************************************************************
	subroutine clrmenu
c
	write(0,12)
12	format(5x,'color menu:',/,5x,'0 - black',/,5x,'1 - red',/,
     *  5x,'2 - green',/,5x,'3 - yellow',/,5x,'4 - blue',/,5x,
     *  '5 - magenta',/,5x,'6 - cyan',/,5x,'7 - white',/,5x,
     *  '8 - grey',/,5x,'9 - orange',/,5x,'10 - l. brown',/,5x,
     *  '11 - brown',/,5x,'12 - sky blue',/,5x,'13 - violet',
     *  /,5x,'14 - turqoise',/,5x,'15 - dark green')
	return
	end
***************************************************************************
*
* subroutine itmmenu does the following:
* (item menu)
*   + display item menu like this:
*     s - square
*     c - circle
*     t - triangle
*     r - rectangle
*     l - line
*     m - move and fill
****************************************************************************
	subroutine itmmenu
c
	write(0,22)
22	format(5x,'items menu:',/,5x,'s - square',/,5x,'c - circle',
     *  /,5x,'t - triangle',/,5x,'r - rectangle',/,5x,'l - line',
     *  /,5x,'m - move and fill')
	return
	end
**************************************************************************
*
* subroutine ditem does the following:
*  (draw item)
*     + This routine is called after items menu
*     + read one character item
*     + standard item?
*       - yes->
*              * process item (procitm)
*              * if item is a line that
*                belongs to a (ucp) then
*                consider it differently
*  
*                # (ucp) line--(upolyln)
*                # (ucp) done--(ispdone)
*       - no->
*              * (ucp) or background segment
*              * proccess it--(mvwhere)
*       - otherwise->
*              * error-undefined answer
*                      try again
*************************************************************************
	subroutine ditem
	common/info/color,len,width,x1,y1,x2,y2,item
	common/poly/iflag,numpoly,ifivply(5)
	integer color
	real x1,y1,x2,y2,len,width
	character*1 item
c
	do 78 i=1,4
	read(5,88)item
88	format(a1)
c
	if(item.eq.'s' .or. item.eq.'S')then
	     item='s'
	     i=5
	elseif(item.eq.'c' .or. item.eq.'C')then
	     item='c'
	     i=5
	elseif(item.eq.'t' .or. item.eq.'T')then
	     item='t'
	     i=5
	elseif(item.eq.'r' .or. item.eq.'R')then
	     item='r'
	     i=5
	elseif(item.eq.'l' .or. item.eq.'L')then
	     item='l'
	     i=5
	elseif(item.eq.'m' .or. item.eq.'M')then
c this does not mean that there is item 'm' but is done this way for
c consistency of code.
	     item='m'
	     call dmove
	     i=5
	else
	     call error(3)
	     call itmmenu
	endif
78	continue
	if(item.ne.'m')then
	    call procitm
	    if(item.eq.'l'.and.iflag.eq.1)then
	            call upolyln
	            call ispdone
	    endif
	else
	    call mvwhere
	endif
	return
	end
*******************************************************************
*
* subroutine error(code) does the following:
*      + report an error on the screen according
*        to integer value (code).
*******************************************************************
	subroutine error(code)
	integer code
c
	if(code.eq.1)then
              write(0,10)
10            format(5x,'error:incorrect answer')
	elseif(code.eq.2)then
	      write(0,20)
20	      format(5x,'error:incorrect value')
	elseif(code.eq.3)then
	      write(0,30)
30	      format(5x,'error:undefined item')
	elseif(code.eq.4)then
	      write(0,40)
40	      format(5x,'error:undefined color')
	elseif(code.eq.5)then
	      write(0,50)
50	      format(5x,'error:undefined command')
	elseif(code.eq.6)then
	      write(0,60)
60	      format(5x,'error:cannot move this segment')
	elseif(code.eq.7)then
	      write(0,70)
70	      format(5x,'error:cannot move item will be out of bounds',/,
     *                  5x,'try again')
	elseif(code.eq.8)then
	      write(0,80)
80	      format(5x,'error:cannot draw item out of bounds,try again')
	elseif(code.eq.9)then
	      write(0,90)
90	      format(5x,'error:No saved image')
	elseif(code.eq.11)then
	      write(0,110)
110	      format(5x,'error:cannot add segment background,it exist')
	else
	      continue
	endif
	return
	end
**********************************************************************
*
* subroutine itmclr does the following:
* (item color)
*
*     + This routine is called after color menu
*     + read a valid integer color value and 
*       save it in temporary working block (twb).
***********************************************************************
	subroutine itmclr
	common/info/color,len,width,x1,y1,x2,y2,item
	character*1 item
	real len,x1,y1,x2,y2,width
	integer color
c
	write(0,51)
51	format(5x,'To add color to this item')
	call pickclr(color)
c
	return
	end
**************************************************************************
*
* subroutine gchange(ans) does the following:
*  (globle change -- image editing)
* 
*    + display a question on the terminal
*    + expect an answer.
*    + read answer,return value to calling 
*      program
***************************************************************************
	subroutine gchange(ans)
c
	character*1 ans
	write(0,91)
91	format(5x,'Do you want to change anything on this page'
     *  ,/,5x,'answer: y-yes , n-no')
c
	read(5,101)ans
101	format(a1)
	return
	end
**************************************************************************
*
* subroutine itmpnt does the following:
*  (item point--item position)
*     + read item position (x1,y1) by 
*       communicating interactivly with
*       user.
*     + standard item
*       - square
*       - rectangle
*       - triangle
*       - line
*       ( specify (blc) coords)
*       - circle
*       (specify center coords)
*     + position within bounds?
*       -yes->
*             * store position in (twb)
*       -no->
*             * error-try again
***************************************************************************
	subroutine itmpnt
	common/info/color,len,width,x1,y1,x2,y2,item
	character*1 item
	real len,x1,y1,x2,y2,width
	integer color
	do 121 j=1,4
	write(0,11)
11	format(5x,'For items:',/,15x,'square',/,15x,'rectangle',
     *  /,15x,'triangle',/,15x,'line:',/,5x,'specify bottom'
     *  'left corner coords (blc)',//,5x,'For item:',/,15x,
     *  'circle',/,5x,'specify center coords',/,5x,
     *  'like this: real x-value blank real y-value',/,5x,
     *  '(ex): 2.5 3.0')
c
	read(5,*)x1,y1
c
	if(x1.lt.0.0 .or. x1.ge.10.0 .or. y1.lt.0.0 .or.
     *     y1.ge.10.0)then
	                   call error(2)
	else
	                   j=5
	endif
121	continue
	return
	end
**************************************************************************
*
* subroutine itmmes does the following:
* (item measurment)
*    + communicating interactivley with user
*    + using info in (twb) calculate the
*      limits on required measuerment.
*    + ask user to specify thoes measuerment
*      within thoes limits.
*    + valid specification:
*        - use it to calculate other info
*        - store info in (twb).
*    + unvalid specification:
*        - error-- try again.
*    + for item:
*        - square
*          * read side length
*          * calculate width,(trc)
*        - triangle
*          * read side length
*          * calculate (trc)
*        - rectangle
*          * read side length,width
*          * calculate (trc)
*        - circle
*          * read raduis
*        - line
*          * read (trc)
*          * calculate length
*****************************************************************************
	subroutine itmmes
	common/info/color,len,width,x1,y1,x2,y2,item
	character*1 item
	real x1,y1,x2,y2,raduis,len,tlength,width,twidth
	real tx1,ty1,trad
	integer color
c
c  ( S Q U A R E  O R  T R I A N G L E )
	if(item.eq.'s' .or. item.eq.'t')then
c
c calculate  side length limit.
c
	if(x1.ge.y1)then
	   tlength=10.0-x1
	else
	   tlength=10.0-y1
	endif
c
c ask user to input value within limit.
c
	do 21 k=1,4
	write(0,31)tlength
31	format(5x,'specify real side length >0.0 & <=',F4.1,
     *  /,5x,'like this: 1.2')
c
c  read side length value.
c
	read(5,*)len
c
c check if value actually within limits?
c
	if(len.lt.0.0 .or. len.gt.tlength)then
c
c unvalid value,report an error then allow user
c 3 chances to fix error.
c
	                 call error(2)
	else
c
c valid value,calculate other info then store
c in (twb)--(common block info).
c
	                 k=5
	                 width=0.0
	          if(item.eq.'s')then
	                 x2=x1+len
	                 y2=y1+len
	          else
	                 x2=0.0
	                 y2=0.0
	          endif
	endif
21	continue
c
c ( R E C T A N G L E )
c
	elseif(item.eq.'r')then
	do 24 j=1,4
	twidth=10.0-x1
	tlength=10.0-y1
	write(0,34)twidth,tlength
34	format(5x,'specify width to be <=',F4.1,
     *  /,5x,'specify length to be <=',F4.1,
     *  /,5x,'like this:1.5 blank 1.0')
c
	read(5,*)width,len
	if(width.lt.0.0 .or. len.lt. 0.0 .or.width.gt.twidth .or. 
     *     len.gt.tlength)then
	              call error(2)
	else
	              j=5
	              x2=x1+width
	              y2=y1+len
	endif
24	continue
c
c ( C I R C L E )
c
	elseif(item.eq.'c')then
	      if(x1.eq.y1.and.x1.eq.5.0)then
	          trad=5.0
	      elseif(x1.gt.y1)then
	          tx1=10.0-x1
	          if(y1.lt.tx1)then
	                trad=y1
	          else
	                trad=tx1
	          endif
	      elseif(x1.lt.y1)then
	          ty1=10.0-y1
	          if(x1.lt.ty1)then
	                trad=x1
	          else
	                trad=ty1
	          endif
	      else
	          if(x1.lt.5.0)then
	               trad=x1
	          else
	               trad=10.0-x1
	           endif
	      endif
c
	do 23 i=1,4
	write(0,33)trad
33	format(5x,'specify real raduis>0.0 & <=',F4.1,
     *  /,5x,'like this:1.0,max raduis=5.0')
c
	read(5,*)raduis
	if(raduis.lt.0.0 .or. raduis.gt.trad)then
	                 call error(2)
	else
	                 i=5
	                 len=raduis
	                 width=0.0
	                 x2=0.0
	                 y2=0.0
	endif
23	continue
c
c ( L I N E )
c
	elseif(item.eq.'l')then
	do 16 m=1,4
	write(0,26)
26	format(5x,'specify ending point coords,(x,y)>=0.0 &<=10.0',
     *  /,5x,'(ex):2.5 blank 2.0')
	read(5,*)x2,y2
	if(x2.lt.0.0 .or.x2.gt.10.0 .or. y2.lt.0.0 .or. 
     *     y2.gt.10.0)then
	              call error(2)
	else
	     len=sqrt(((x2-x1)**2)+((y2-y1)**2))
	              width=0.0
	              m=5
	endif
16	continue
	else
	     continue
	endif
	return
	end
**************************************************************************
*
* subroutine ready does the following:
*  + set window,screen,viewport sizes.
**************************************************************************
	subroutine ready
c
	call window(-1.0,11.0,-1.0,11.0)
	call screen(-1.0,11.0,-1.0,11.0)
	call vwport(-1.0,11.0,-1.0,11.0)
	return
	end
*****************************************************************************
*
* subroutine showitm does the following:
* (show item)
*      + using info in (twb) find out
*        type of current item
*      + valid item
*        - call corresponding routine
*      + unvalid item.
*        - error-try again
*****************************************************************************
	subroutine showitm
	common/info/color,len,width,x1,y1,x2,y2,item
	character*1 item
	integer color
	real x1,y1,x2,y2,len,width
c
	call clr
	do 20 i=1,4
	if(item.eq.'s' .or. item.eq.'r')then
	      call showrec
	      i=5
	elseif(item.eq.'c')then
	      call showcir
	      i=5
	elseif(item.eq.'t')then
	      call showtri
	      i=5
	elseif(item.eq.'l')then
	      call showlin
	      i=5
	else
	      call error(3)
	endif
20	continue
	return
	end
******************************************************************************
*
* subroutine showcir does the following:
* (show circle)
*     + using item (twb) to build circle
*       code in (df)
*      - filled circle
*        * use (AED) built in command (dcl)
*      - outlined circle
*        * use 360 line segments unit circle
*          (cir)
******************************************************************************
	subroutine showcir
	common/info/color,len,width,x1,y1,x2,y2,item
	common/minfo/sorhitm
	character*1 item
	real len,x1,y1,x2,y2,width,tx1,ty1
	integer color
c
	if(sorhitm.eq.1.0)then
	      call move(x1,y1)
	      call sec(color)
	      call dcl(len)
	      call ifl
	else
	      tx1=x1-len
	      ty1=y1-len
	      call sec(color)
	      call scl(len,len)
	      call tlt(tx1,ty1)
	      call cir
	endif
	return
	end
*****************************************************************************
*
* subroutine showrec does the following:
* (show rectangle)
*    + use item (twb) to build code for:
*      - square
*        * filled- use (AED) built in command
*                  (dfr)
*        * outlined- use a self build unit
*                    square (sqr)
*      - rectangle
*        * filled- use (AED) built in command
*                  (dfr)
*        * outlined- use line segments to 
*                    construct ractangle.
*****************************************************************************
	subroutine showrec
	common/info/color,len,width,x1,y1,x2,y2,item
	common/minfo/sorhitm
	character*1 item
	integer color
	real x1,y1,x2,y2,len,width
c
	if(sorhitm.eq.1.0)then
	        call dfr(color,x1,y1,x2,y2)
	else
	     call sec(color)
	     if(item.eq.'s')then
	        call scl(len,len)
	        call tlt(x1,y1)
	        call sqr
	     else
	        call move(x1,y1)
	        call line(x2,y1)
	        call line(x2,y2)
	        call line(x1,y2)
	        call line(x1,y1)
	     endif
	endif
	return
	end
******************************************************************************
*
* subroutine showtri does the following:
* (show triangle)
*     + use items (twb) to build code for
*       a triangle.
*     + using a self build unit triangle
*       (triang)
*     + filled
*       - move in and fill with color
*     + outlined
*       - leave as is
*******************************************************************************
	subroutine showtri
	common/info/color,len,width,x1,y1,x2,y2,item
	common/minfo/sorhitm
	character*1 item
	integer color
	real x1,y1,x2,y2,len,width,sorhitm,delta
c
	    call sec(color)
            call scl(len,len)
	    call tlt(x1,y1)
	    call triang
	  if(sorhitm.eq.1.0)then
	    call clr
	    delta=len/2.0
	    call move(x1+delta,y1+delta)
	    call ifl
	  endif
	return
	end
******************************************************************************
*
* subroutine showlin does the following:
* (show line)
*   + use items (twb) to build code
*     for a line.
******************************************************************************
	subroutine showlin
	common/info/color,len,width,x1,y1,x2,y2,item
	character*1 item
	integer color
	real x1,y1,x2,y2,len,width
c
             call sec(color)
	     call move(x1,y1)
             call line(x2,y2)
	return
	end
DataMuseum.dk

DKUUG/EUUG Conference tapes

⟦cb32aa9d6⟧ TextFile

Derivation

TextFile
