⟦394dcfac9⟧

TextFile

*****************************************************************************
*
* subroutine pgdone does the following:
* (page done)
*      + output device is AED terminal.
*        - change modes from graphics
*          mode to alpha mode.
******************************************************************************
	subroutine pgdone
	character*1 alpha
c
	ialpha=1
	alpha=char(ialpha)
	call prnt(alpha)
	return
	end
*****************************************************************************
*
* subroutine newpage does the following:
* (new page)
*   + reinitialize for new page
*   + update number of pages.
*************************************************************************
	subroutine newpage
	common/device/lastx,lasty,numpag
c
c  user ready to draw another page, need to reinitialize.
	call clr
	call init
c update numpag by one.
	numpag=numpag+1
	return
	end
***********************************************************************
* subroutine rdcomnd(itmsnum) does the following:
* (read command)
*   + This routine follows globle change menu
*   + read commnad
*   + valid command
*     - 'm'--> move
*       * move item numbered (itmsnum)
*     - 'e'--> erase
*       * erase (delete) item numbered
*         (itmsnum)
*     - 'a'--> add
*       * add item numbered (itmsnum)
*         # possible to add another item
*         # yes-->
*           - adjust (df) counter to next
*             available space.
*           - display items menu
*           - proceed to draw item
*         # no-->
*           - send a warning that the limit
*             of items has been used
*   + unvalid command
*     - error
*     - display globle change menu
*     - allows 3 chances to correct 
*       error
*
**********************************************************************
	subroutine rdcomnd(itmsnum)
	integer itmsnum
	common/num/numitms
	common/space/ifree
	common/contr/icnt
	common/table/tblitms(20,10),icolor(20),items(20)
	common/gc/igcflg
	common/aucp/iaucp
	character*1 command,items
c
	do 20 i=1,4
	      read(5,30)command
30	      format(a1)
	if(command.eq.'m' .or. command.eq.'M')then
	      call movitm(itmsnum)
	      i=5
	elseif(command.eq.'e' .or. command.eq.'E')then
	      call delitm(itmsnum)
	      igcflg=1
	      i=5
	elseif(command.eq.'a' .or. command.eq.'A')then
	      if(numitms.lt.20)then
	          icnt=ifree
	          iaucp=1
	          call itmmenu
	          call ditem
	          iaucp=0
	      else
	          write(0,40)
40	          format(5x,'Warning:Cannot add another item',
     *            /,5x,'you have used the limit of items/page')
	      endif
	      i=5
	else
	      call error(5)
	      call gcmenu
	endif
20	continue
	return
	end
*****************************************************************************
*
* subroutine lsitems does the following:
* (list items)
*     + list the content of current segment
*       table.
*
*****************************************************************************
	subroutine lsitems
	common/num/numitms
	common/table/tblitms(20,10),icolor(20),items(20)
	character*1 items
c
	write(0,10)
10	format(1x,'item no.',2x,'item',2x,'color',2x,'sl or raduis',
     *         2x,'blc or center',2x,'trc')
	do 20 i=1,numitms
	write(0,30)i,items(i),icolor(i),(tblitms(i,j),j=1,5)
30	format(1x,I2,8x,a1,5x,I2,6x,F6.2,5x,F6.2,1x,F6.2,2x,F6.2,1x,F6.2)
20	continue
	return
	end
***************************************************************************
*
* subroutine wtitems does the following:
* (write items)
*      + wirte items (twb) into (pwb)
*        segment table.
*      + list segment table content
*
****************************************************************************
	subroutine wtitems
	common/info/color,len,width,x1,y1,x2,y2,item
	common/minfo/sorhitm
	common/num/numitms
	common/table/tblitms(20,10),icolor(20),items(20)
	character*1 items,item
	real x1,y1,x2,y2,len,width
	integer numitms,color
c
	numitms=numitms+1
	items(numitms)=item
	icolor(numitms)=color
c
	tblitms(numitms,1)=len
	tblitms(numitms,2)=x1
	tblitms(numitms,3)=y1
	tblitms(numitms,4)=x2
	tblitms(numitms,5)=y2
	tblitms(numitms,7)=sorhitm
c
	call lsitems
	return
	end
***************************************************************************
*
* subroutine pickitm(onenum) does the following:
*  (pick one item)
*      + This routine is called after listing
*        of segment table.
*      + ask user to input one items number
*      + read number
*      + valid item number
*        - yes-->
*          * return
*        - no-->
*          * error- try again
*
***************************************************************************
	subroutine pickitm(onenum)
	integer onenum
c
	do 30 i=1,4
	write(0,10)
10	format(5x,'make a selection by specifying items number')
	read(5,20)onenum
20	format(I2)
	if(onenum.lt.0 .or. onenum.gt.20)then
	       call error(2)
	else
	       i=5
	endif
30	continue
	return
	end
*******************************************************************************
*
* subroutine gcmenu does the following:
* (globle change menu - image editing)
*      + display globle change menu like this
*        * m - move item
*        * e - erase (delete) item
*        * a - add item
*
*******************************************************************************
	subroutine gcmenu
c
	write(0,10)
10	format(5x,'choices are:',/,10x,'m-move item',/,10x,
     *  'e-erase item',/,10x,'a-add item')
	return
	end
*****************************************************************************
*
* subroutine movitm(onenum) does the following:
* (move item)
*      + access (pwb) to find out items type
*      + item is (ucp),(bkgd),(line belonges
*        to (ucp))
*        - error--cannot move this item
*      + otherwise
*        - erase item from screen
*        - restructure image after erasing
*          -- erased item overlapped other segments
*          * send only those segments that 
*            overlapped erased item according
*            to their priorities
*        else
*          -- erased item stand alone
*          * send item only
*        - draw moved item like this
*          -- moved item overlaps other segments
*          * send segments according to their
*            priorities including moved segment
*        else
*          -- send item only
*
******************************************************************************
	subroutine movitm(onenum)
	integer onenum,entry
	common/table/tblitms(20,10),icolor(20),items(20)
	common lstovlp(380),jo
	character*1 items
c
	if(items(onenum).eq.'b'.or.items(onenum).eq.'u'.or.
     *  (items(onenum).eq.'l'.and.tblitms(onenum,10).eq.0.0))then
	      call error(6)
	else
	      call tempinf(onenum)
	      call eraitm(onenum)
	      call issovlp(onenum)
	      call search(onenum,entry)
	      call dlentry(entry)
	      jo=jo-1
	      if(jo.gt.1)then
	       call sendsgs
	      else
	       call sendcod(onenum)
	      endif
	      call tempinf(onenum)
	      call redmitm(onenum)
	      call issovlp(onenum)
	      if(jo.gt.1)then
	            call sendsgs
	      else
	           call sendcod(onenum)
	      endif
	endif
	return
	end
****************************************************************************
*
* subroutine delitm(onenum) does the following:
* (delete item)
*    + delete an item from image for ever
*      - special cases:
*        * line belonges to (ucp)
*          # error--cannot delete it yet
*                   have to delete its (ucp)
*                   first
*        * (bkgd) or (ucp)
*          # handle seperatly
*      - general cases:
*        * erase item form screen
*        * restructure image accordingly
*        * delete item entry from segment
*          table
*        * delete segment from (df)
*
****************************************************************************
	subroutine delitm(onenum)
	integer onenum,entry
	common/table/tblitms(20,10),icolor(20),items(20)
	common lstovlp(380),jo
	character*1 items
c
	if(items(onenum).eq.'l'.and.tblitms(onenum,10).eq.0.0)then
	   write(0,10)
10	   format(5x,'attention:cannot erase this line,belongs to',/,15x,
     *            'a user constructed polygon')
	else
	if(items(onenum).eq.'b')then
	   call dlbkgd(onenum)
	elseif(items(onenum).eq.'u')then
	   call delucp(onenum)
	else
	   call tempinf(onenum)
	   call eraitm(onenum)
	   call issovlp(onenum)
	   call search(onenum,entry)
	   call dlentry(entry)
	   jo=jo-1
	   call sendsgs
	   call updf(onenum)
	   call upentry(onenum)
	   call cpnums(onenum)
	endif
	endif
	return
	end
*************************************************************************
*
* subroutine cpnums(idsnum) does the following:
* (change (ucp)s numbers)
* (idsnum-deleted segment number)
*************************************************************************
	subroutine cpnums(idsnum)
	common/poly/iflag,numpoly,ifivply(5)
	common/llist/lnlist(5,2),lncontr
c
	do 20 i=1,numpoly
	  if(ifivply(i).gt.idsnum)then
	      ifivply(i)=ifivply(i)-1
	      lnlist(i,1)=lnlist(i,1)-1
	  endif
20 	continue
	return
	end
*****************************************************************************
*
* subroutine eraitm(onentry) does the following:
* (erase item)
*      + item deletion flag off
*       - yes-->
*        * return
*       -no-->
*        * special case:
*          # (ucp)-handle sepeatly
*        * general cases:
*          # erase item to background color
*****************************************************************************
	subroutine eraitm(onentry)
	integer onentry
	common/table/tblitms(20,10),icolor(20),items(20)
	common/info/color,len,width,x1,y1,x2,y2,item
	common/contr/icnt
	character*1 items,item
	real x1,y1,x2,y2,len,width
	integer iclr,color,tempclr
c
	if(tblitms(onentry,10).ne.0.0)then
	    tempclr=color
	    call srchtbl(iclr)
	    color=iclr
	    icnt=tblitms(onentry,8)
	    call showitm
	    tblitms(onentry,9)=icnt-1
	    call sendcod(onentry)
	    color=tempclr
	endif
	return
	end

****************************************************************************
*
* subroutine redmitm(inum) does the following:
* (redraw moved item)
*     + read new position
*     + update (twb) due to new position
*     + new position within bounds?
*       - yes-->
*         * update (pwb) segment table
*         * update overlapping table
*         * reconstruct segment
*       - no-->
*         * error--try again
*         * read new position
*         * repeat loop
****************************************************************************
	subroutine redmitm(inum)
	integer inum
	common/info/color,len,width,x1,y1,x2,y2,item
	common/table/tblitms(20,10),icolor(20),items(20)
	common lstovlp(380),jo
	common/contr/icnt
	common/ln/xtemp,ytemp
	character*1 items,cmnd,item
	real xtemp,ytemp,len,width,x1,y1,x2,y2
	integer reply,color
c
	cmnd='p'
	xtemp=x1
	ytemp=y1
	call itmpnt
	call upinfo(cmnd)
	  do 24 i=1,3
	     call ckchang(inum,cmnd,reply)
	     if(reply.eq.0)then
	     call uptable(inum,cmnd)
	     call blnkrow(inum)
	     call ckovlap(inum)
	     icnt=tblitms(inum,8)
	     call showitm
	     tblitms(inum,9)=icnt-1
	     call eraitm(inum)
	     icnt=tblitms(inum,8)
	     call showitm
	     tblitms(inum,9)=icnt-1
	     i=4
	     else
	         call error(7)
	         call itmpnt
	         call upinfo(cmnd)
	     endif
24	  continue
	return
	end
*******************************************************************************
*
* subroutine upentry(numone) does the following:
* (update segment table entry)
*       + delete segment table entry (numone)
*       + delete entry (numone) from overlapping
*         table
*       + decrement number of image items (numitms)
*******************************************************************************
	subroutine upentry(numone)
	integer numone
	common/num/numitms
	common/table/tblitms(20,10),icolor(20),items(20)
	character*1 items
	integer num1
c
	if(numone.eq.1.and.numitms.eq.1)then
	       num1=1
	else
	       num1=numitms-1
	endif
	do 10 i=numone,num1
	  do 20 j=1,10
	     tblitms(i,j)=tblitms(i+1,j)
20	  continue
	  icolor(i)=icolor(i+1)
	  items(i)=items(i+1)
10	continue
c update the overlapping table .
	call upotbl(numone)
	numitms=numitms-1
	return
	end
***********************************************************************
*
* subroutine rstable does the following:
*  (reset segment table)
***********************************************************************
	subroutine rstable
	common/num/numitms
	common/table/tblitms(20,10),icolor(20),items(20)
	character*1 items
c
	do 10 i=1,20
           do 20 j=1,5
	      tblitms(i,j)=0.0
20         continue
	   icolor(i)=0
	   items(i)=' '
10	continue
	do 30 k=1,20
	      tblitms(k,6)=1.0
	      tblitms(k,10)=1.0
30	continue
	numitms=0
	return
	end
*****************************************************************************
*
* subroutine pickclr(clrnum) does the following:
*  (pick one color)
*    + ask user to input an integer color value
*    + display color menu
*    + read color value
*    + valid
*     - yes-->
*       * return
*     - no-->
*       * error-try again
*****************************************************************************
	subroutine pickclr(clrnum)
	integer clrnum
c
	do 20 i=1,4
	  write(0,5)
5	  format(5x,'Make a selection by specifying color number:')
	  call clrmenu
	  write(0,30)
30	  format(1x,/,5x,'input integer value,like this (ex): 10')
	  read(5,10)clrnum
10	  format(I2)
	  if(clrnum.lt.0.or.clrnum.gt.15)then
	     call error(4)
	  else
	     i=5
	  endif
20	continue
	return
	end
DataMuseum.dk

DKUUG/EUUG Conference tapes

⟦394dcfac9⟧ TextFile

Derivation

TextFile
