⟦8dfeda14b⟧

TextFile

****************************************************************************
*
* subroutine spfyitm does the following:
* ( specify item)
*    + items position,measurment,color
*      interior saved in items (twb).
****************************************************************************
	subroutine spfyitm
c
	call itmpnt
	call itmmes
	call itmclr
	call itmint
	return
	end
*******************************************************************************
*
* subroutine respfy(element) does the following:
* (respecify item - item editing)
*     + display local change menu
*     + read command
*     + valid command
*      - yes-->
*        * command--'p'
*          # save old position
*          # read and store new position
*        * command--'c'
*          # read and save new color
*        * command--'m'
*          # read and save new measurment
*      - no-->
*        * error--try again
*******************************************************************************
	subroutine respfy(element)
	character*1 element
	common/info/color,len,width,x1,y1,x2,y2,item
	common/ln/xtemp,ytemp
	real xtemp,ytemp,len,width,x1,y1,x2,y2
	integer color
	character*1 item
c
                    call lcmenu
	            read(5,23)element
23                  format(a1)
	if(element.eq.'p' .or. element.eq.'P')then
	            xtemp=x1
	            ytemp=y1
	            call itmpnt
	            element='p'
	            call upinfo(element)
	elseif(element.eq.'c' .or. element.eq.'C')then
	            call itmclr
	            element='c'
	elseif(element.eq.'m' .or. element.eq.'M')then
	            call itmmes
	            element='m'
	else
	            call error(5)
	endif
	return
	end
******************************************************************************
*
* subroutine dsplyit(segno) does the following:
* ( display item)
*     + construct segment in (df)
*     + save segment begin and end position
*       in segment table
*     + update (df) next available space counter
*       (ifree)
*     + send segment to screen
******************************************************************************
	subroutine dsplyit(segno)
	integer segno
	common/table/tblitms(20,10),icolor(20),items(20)
	common/contr/icnt
	common/space/ifree
	character*1 items
c
	      tblitms(segno,8)=icnt
	      call showitm
	      tblitms(segno,9)=icnt-1
	      call eraitm(segno)
	      icnt=tblitms(segno,8)
	        call showitm
	      tblitms(segno,9)=icnt-1
	      ifree=icnt
	      call sendcod(segno)
	return
	end
****************************************************************************
*
* subroutine procitm does the following:
* (process item)
*     + specify item
*     + transfer items (twb) into (pwb)
*     + check items overlapping and store
*       info in segment overlapping table
*     + display item on screen
*     + item editing?
*      - yes-->
*        * erase item
*        * restructure image properly
*        * respecify item
*        * valid specification?
*         - yes-->
*          # update segment table 
*          # check items new overlapping
*            and store into segment overlapping
*            table
*          # reconstruct segment due to changes
*          # display segment on screen
*         - no-->
*          # error--try again
*       - no-->
*        * return
*       - otherwise
*        * error--try again
****************************************************************************
	subroutine procitm
	common/table/tblitms(20,10),icolor(20),items(20)
	common/num/numitms
	common/contr/icnt
	common/ln/xtemp,ytemp
	common lstovlp(380),jo
	character*1 feature,answer,items
	real xtemp,ytemp
	integer ans2,entry
c
	call spfyitm
	call wtitems
	call dsplyit(numitms)
	call ckovlap(numitms)
	  do 14 i=1,3
	    do 34 k=1,4
	        call change(answer)
	        if(answer.eq.'y'.or.answer.eq.'Y')then
	          call eraitm(numitms)
	          call issovlp(numitms)
	          if(lstovlp(1).ne.0)then
	          call search(numitms,entry)
	          call dlentry(entry)
	          jo=jo-1
	          call sendsgs
	          endif
	          call tempinf(numitms)
	          call respfy(feature)
	            do 24 j=1,4
	              call ckchang(numitms,feature,ans2)
	              if(ans2.eq.0)then
	               call uptable(numitms,feature)
	               call blnkrow(numitms)
	               call ckovlap(numitms)
	               icnt=tblitms(numitms,8)
	               call showitm
	               tblitms(numitms,9)=icnt-1
	               call eraitm(numitms)
	               icnt=tblitms(numitms,8)
	               call showitm
	               tblitms(numitms,9)=icnt-1
	               call sendcod(numitms)
	               j=5
	              else
	               call error(8)
	               call tempinf(numitms)
	               if(feature.eq.'p')then
	                 xtemp=x1
	                 ytemp=y1
	                 call itmpnt
	                 call upinfo(feature)
	               else
	                 call itmmes
	               endif
	              endif
24	            continue
	            k=5
	        elseif(answer.eq.'n'.or.answer.eq.'N')then
	          i=4
	          k=5
	        else
	          call error(1)
	        endif
34	        continue
14	  continue
	return
	end
*****************************************************************************
*
* subroutine ckchang(itsnum,chgelmt,yesorno) does the following:
* (check item change for validity)
*      + items number (itsnum)
*      + command issued (chgelmt)
*      + validity answer (yesorno)
*****************************************************************************
	subroutine ckchang(itsnum,chgelmt,yesorno)
	character*1 chgelmt
	integer yesorno,itsnum
c
	if(chgelmt.eq.'p')then
	    call itmptin(itsnum,yesorno)
	elseif(chgelmt.eq.'m')then
	    call itmmsin(itsnum,yesorno)
	else
	    yesorno=0
	endif
	return
	end
******************************************************************************
*
* subroutine itmptin(num1,ans1) does the following:
* (item new position inbounds)
*     + items number (num1)
*     + validity of position answer (ans1)
*       - valid--return (ans1=1)
*       - unvalid--return (ans1=0)
*     + method used to check validity of position
*       (Boxing of image items)
******************************************************************************
	subroutine itmptin(num1,ans1)
	integer num1,ans1
	common/info/color,len,width,x1,y1,x2,y2,item
	common/table/tblitms(20,10),icolor(20),items(20)
	character*1 items,item
	real x1,y1,x2,y2,len,width
	real itmbox(8),x1temp,y1temp,x2temp,y2temp
	integer color
c
	x1temp=tblitms(num1,2)
	y1temp=tblitms(num1,3)
	x2temp=tblitms(num1,4)
	y2temp=tblitms(num1,5)
	tblitms(num1,2)=x1
	tblitms(num1,3)=y1
	tblitms(num1,4)=x2
	tblitms(num1,5)=y2
	call boxsitm(num1,itmbox)
	call boxout(itmbox,ans1)
	tblitms(num1,2)=x1temp
	tblitms(num1,3)=y1temp
	tblitms(num1,4)=x2temp
	tblitms(num1,5)=y2temp
	return
	end
*****************************************************************************
*
* subroutine itmmsin(num2,ans2) does the following:
* (items new position inbounds)
*      + item number (num2)
*      + validity of new position answer (ans2)
*        - valid--returns (ans2=1)
*        - unvalid--returns (ans2=0)
*      + method used to check validity of measurment
*        (Boxing of image items)
*****************************************************************************
	subroutine itmmsin(num2,ans2)
	integer num2,ans2
	common/info/color,len,width,x1,y1,x2,y2,item
	common/table/tblitms(20,10),icolor(20),items(20)
	real x1,y1,x2,y2,len,width
	character*1 items,item
	real itmbox(8),sltemp,x2temp,y2temp
	integer color
c
	sltemp=tblitms(num2,1)
	x2temp=tblitms(num2,4)
	y2temp=tblitms(num2,5)
	tblitms(num2,1)=len
	tblitms(num2,4)=x2
	tblitms(num2,5)=y2
	call boxsitm(num2,itmbox)
	call boxout(itmbox,ans2)
	tblitms(num2,1)=sltemp
	tblitms(num2,4)=x2temp
	tblitms(num2,5)=y2temp
	return
	end
****************************************************************************
*
* subroutine uptable(number,element) does the following:
* (update segment table)
*     + update segment table after an item has under gone
*       a change
*     + items number (number)
*     + command issued (element)
*     + update segment table entry (number) accordingly
*       (by accessing items (twb) and (pwb))
*     + list updated segment table
****************************************************************************
	subroutine uptable(number,element)
	common/table/tblitms(20,10),icolor(20),items(20)
	common/info/color,len,width,x1,y1,x2,y2,item
	character*1 items,item,element
	real x1,y1,x2,y2,len,width
	integer color,number
c
	if(element.eq.'p')then
	tblitms(number,2)=x1
	tblitms(number,3)=y1
	  if(items(number).eq.'s' .or. items(number).eq.'r'.or.
     *       items(number).eq.'l')then
	    tblitms(number,4)=x2
	    tblitms(number,5)=y2
	  endif
	elseif(element.eq.'c')then
	icolor(number)=color
	elseif(element.eq.'m')then
	tblitms(number,1)=len
	  if(items(number).eq.'s'.or.items(number).eq.'r'.or.
     *       items(number).eq.'l')then
	     tblitms(number,4)=x2
	     tblitms(number,5)=y2
	  endif
	else
	    continue
	endif
	    call lsitems
	return
	end
****************************************************************************
*
* subroutine upinfo(elmnt) does the following:
* (update information in (twb)
*      + command issued (elmnt)
*      + check items type and update info
*        accordingly
****************************************************************************
	subroutine upinfo(elmnt)
	common/info/color,len,width,x1,y1,x2,y2,item
	common/ln/xtemp,ytemp
	character*1 item,elmnt
	real x1,y1,x2,y2,len,width,xtemp,ytemp,xdiff,ydiff
	integer color
c
	if(item.eq.'s'.and.elmnt.eq.'p')then
	          x2=x1+len
	          y2=y1+len
	elseif(item.eq.'r'.and.elmnt.eq.'p')then
	          x2=x1+width
	          y2=y1+len
	elseif(item.eq.'l'.and.elmnt.eq.'p')then
	          xdiff=x2-xtemp
	          ydiff=y2-ytemp
	          x2=xdiff+x1
	          y2=ydiff+y1
	else
	          continue
	endif
	return
	end
*****************************************************************************
*
* subroutine tempinf(one) does the following:
* (temporary transfer of information)
*      + items number (one)
*      + copy items information from (pwb) to
*        (twb)
*****************************************************************************
	subroutine tempinf(one)
	common/table/tblitms(20,10),icolor(20),items(20)
	common/info/color,len,width,x1,y1,x2,y2,item
	common/minfo/sorhitm
	character*1 items,item
	real x1,y1,x2,y2,len,width
	integer color,one
c
	item=items(one)
	len=tblitms(one,1)
	x1=tblitms(one,2)
	y1=tblitms(one,3)
	x2=tblitms(one,4)
	y2=tblitms(one,5)
	color=icolor(one)
	sorhitm=tblitms(one,7)
	if(item.eq.'r')then
	    width=x2-x1
	endif
	return
	end
*******************************************************************************
*
* subroutine updf(segnum) does the following:
*  (update display file)
*     + after a segment deletion update (df)
*     + segment number (segnum)
*     + delete segment code from (df)
*     + adjust (df) next available space (ifree)
*******************************************************************************
	subroutine updf(segnum)
	integer segnum
	common/table/tblitms(20,10),icolor(20),items(20)
	common/num/numitms
	common/space/ifree
	common/page/jpage(6000)
	character*1 items,jpage
	integer begin,end,idspac
c
	begin=tblitms(segnum,8)
	end=tblitms(segnum,9)
	idspac=end-begin+1
27	if(end.lt.ifree)then
	    jpage(begin)=jpage(end+1)
	    begin=begin+1
	    end=end+1
	    go to 27
	else
	    ifree=begin-1
	do 20 i=segnum+1,numitms
	   tblitms(i,8)=tblitms(i,8)-idspac
	   tblitms(i,9)=tblitms(i,9)-idspac
20	continue
	endif
	return
	end
****************************************************************************
*
* subroutine srchtbl(iclrbg) does the following:
*  ( search segment table )
*       + search segment table for segment background
*         color
*       + segment exist
*        - yes-->
*            * return value in (iclrbg)
*        - no-->
*            * return color black
****************************************************************************
	subroutine srchtbl(iclrbg)
	integer iclrbg
	common/table/tblitms(20,10),icolor(20),items(20)
	common/num/numitms
	character*1 items
c
	do 33 i=1,numitms
	  if(items(i).eq.'b')then
	     iclrbg=icolor(i)
	     return
	  endif
33	continue
c if background segment is not there then default iclrbg=0 (black).
	iclrbg=0
	return
	end
****************************************************************************
*
* subroutine intrprt(istart,iend) does the following:
*  (interpret code)
*      + interpret (df) code on the (AED) screen
*        starting at position (istart) and ending
*        at position (iend)
****************************************************************************
	subroutine intrprt(istart,iend)
	common/page/jpage(6000)
	character*1 jpage
c
	do 44 i=istart,iend
	     call prnt(jpage(i))
44	continue
	return
	end
****************************************************************************
*
* subroutine itmint does the following:
*  (items interior)
*      + interactivly ask user if current 
*        item need to be filled or outlined 
*      +  yes-->  fill it
*      +  no-->   outline
*      +  otherwise--> error-try again
*      +  lines considered filled items
****************************************************************************
	subroutine itmint
	common/info/color,len,width,x1,y1,x2,y2,item
	common/minfo/sorhitm
	character*1 item,ans
	real len,width,x1,y1,x2,y2,sorhitm
	integer color
c
	if(item.ne.'l')then
	  do 22 i=1,4
	     write(0,10)
10	     format(5x,'Do you want this item to be filled with color',/,
     *       5x,'answer: y-yes , n-no')
	     read(5,20)ans
20	     format(a1)
	     if(ans.eq.'y'.or.ans.eq.'Y')then
	           sorhitm=1.0
	           i=5
	     elseif(ans.eq.'n'.or.ans.eq.'N')then
	           sorhitm=0.0
	           i=5
	     else
	           call error(1)
	     endif
22	  continue
	else
	  sorhitm=1.0
	endif
	return
	end
DataMuseum.dk

DKUUG/EUUG Conference tapes

⟦8dfeda14b⟧ TextFile

Derivation

TextFile
