home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 9 / 09.iso / e / e003 / 13.ddi / DEMO.FOR < prev    next >
Encoding:
Text File  |  1987-06-21  |  4.6 KB  |  225 lines
  1. C    LOADCC: load nslib and set cc_display flag
  2. C    VIDEO:    load video drive file and get parmeters
  3. C    SCREEN: set current display mode  TEXT or GRAPHICS
  4. C    CLSG:    clear screen within graphics area
  5. C    CLST:    clear text area
  6. C    LLIN:    draw line in absroulate screen cordinate
  7. C    LINE:    draw line in mapping aspect ratio
  8. C    WGRAP:    set graphics limit area
  9. C    WTEXT:    set text limit area
  10. C    QUIT:    recover to normal display mode
  11. C    CIRCLE:    draw arc or circle
  12. C    POS:    read current cursor position
  13. C    LOCATE:    set current cursor position
  14. C    RCORD:    read current cordinary value
  15. C    WCORD:    set current cordinary value
  16. C    INTO:    return cursor to text area
  17. C    SSTEP: set move cursor step and display cord value flag
  18. C    DRAWC: draw cursor line
  19.  
  20. C        function key:
  21. C      PgUp: increase step    PgDn: decrease step
  22. C     move cursor key: move cordinary axis line
  23.  
  24.  
  25. C    CM---color max  XM,YM: width and higth of screen
  26. C    CHX,CHY: text colume and line number
  27. C    XB,YB: aspect ratio    GR: ground color
  28.  
  29.     INTEGER*2 C,XXA,YYA,XXB,YYB,XM,YM,CM,CHX,CHY,XB,YB,GR
  30.     INTEGER*2 XW1,YW1,XW2,YW2,XCW1,YCW1,XCW2,YCW2,X00,Y00
  31.     INTEGER*2 X0,Y0,R,TH1,TH2,CHLIN,CDX,CDY,CCX,CCY,XCC,YCC,CCC,FCC
  32.     CHARACTER*10 CMD,CT1,CT11,CT2,CT22,CT3,CT33,CT4,CT44,CT5,CT55
  33.     CHARACTER*10 CT6,CT66,CT7,CT77,CT8,CT88,CT9,CT99
  34.     ICF=0
  35.     CALL VIDEO(CM,GR,XM,YM,CHX,CHY,XB,YB)
  36.     IF(CM.EQ.0) GOTO 1000
  37.     WRITE(*,*)'0. not cc mode   1. small CC mode   2. large CC'
  38.     READ(*,*)ICC
  39.     IF(ICC.EQ.0) GOTO 111
  40.     IF(ICC.EQ.2) THEN
  41.         CALL SETLC
  42.         GOTO 110
  43.     ENDIF
  44.     CALL LOADCC(ICC)
  45.     IF(ICC.EQ.0) GOTO 1000
  46. 110    ICF=1
  47. 111    CHLIN=4+ICF*2
  48.     YM=YM/8
  49.     YM=YM*8
  50.     TH1=0
  51.     TH2=360
  52.     CDX=20
  53.     CDY=0
  54.     XCC=0
  55.     YCC=0
  56.     C=1
  57.     CALL SCREEN(C)
  58.     CALL CLSG
  59.     C=CM
  60.     IF(GR.EQ.CM) C=C-1
  61.     CCC=CM+256
  62.     FCC=0
  63.     XCOD=XM/2.
  64.     YCOD=YM/2.
  65.     CALL WCORD(XCOD,YCOD)
  66.     XW1=0
  67.     YW1=0
  68.     XW2=XM
  69.     YW2=YM-8*CHLIN-8
  70.     CALL LLIN(XW1,YW2,XW2,YW2,C)
  71.     CALL WGRAP(XW1,YW1,XW2,YW2)
  72.     CALL CLSG
  73.     CALL DRAWC
  74.     XCW1=0
  75.     YCW1=CHY-CHLIN
  76.     XCW2=CHX
  77.     YCW2=CHY
  78.     CALL WTEXT(XCW1,YCW1,XCW2,YCW2)
  79.     XSTEP=10.
  80.     IPSX=CHX-25
  81.     IPSY=0
  82.     CALL SSTEP(XSTEP,1.,IPSX,IPSY)
  83.     CT1='QUIT'
  84.     CT11='quit'
  85.     CT2='LINE'
  86.     CT22='line'
  87.     CT3='COLOR'
  88.     CT33='color'
  89.     CT4='CIRCLE'
  90.     CT44='circle'
  91.     CT5='CLS'
  92.     CT55='cls'
  93.     CT6='MOVE'
  94.     CT66='move'
  95.     CT7='DEMO'
  96.     CT77='demo'
  97.     CT8='ROTATE'
  98.     CT88='rotate'
  99.     CT9='ADD'
  100.     CT99='add'
  101.     IF(ICF.EQ.0) WRITE(*,*)'FORTRAN77 graphics example.'
  102.     IF(ICF.NE.0) WRITE(*,*)'FORTRAN77 ╗µ═╝╩╛╖╢▒φ╤▌.'
  103. 10    IF(ICF.EQ.0) WRITE(*,'(1X,9HCommand: ,\)')
  104.     IF(ICF.NE.0) WRITE(*,'(1X,10H╩Σ╚δ├ⁿ┴ε: ,\)')
  105.     FCC=1
  106.     READ(*,'(20A)')CMD
  107.     IF(CMD.EQ.CT1.OR.CMD.EQ.CT11) GOTO 200
  108.     IF(CMD.EQ.CT2.OR.CMD.EQ.CT22) GOTO 100
  109.     IF(CMD.EQ.CT3.OR.CMD.EQ.CT33) GOTO 400
  110.     IF(CMD.EQ.CT4.OR.CMD.EQ.CT44) GOTO 500
  111.     IF(CMD.EQ.CT5.OR.CMD.EQ.CT55) GOTO 600
  112.     IF(CMD.EQ.CT6.OR.CMD.EQ.CT66) GOTO 700
  113.     IF(CMD.EQ.CT7.OR.CMD.EQ.CT77) GOTO 800
  114.     IF(CMD.EQ.CT8.OR.CMD.EQ.CT88) GOTO 850
  115.     IF(CMD.EQ.CT9.OR.CMD.EQ.CT99) GOTO 710
  116.     GOTO 300
  117. 100    WRITE(*,'(1X,12HFirst point:\)')
  118.     READ(*,*)X1,Y1
  119.     CALL RCORD(XLN,YLN,IFF)
  120.     IF(IFF.NE.0) THEN
  121.     X1=XLN
  122.     Y1=YLN
  123.     ENDIF
  124.     WRITE(*,'(1X,13HSecond point:,\)')
  125.     READ(*,*)X2,Y2
  126.     CALL RCORD(XLN,YLN,IFF)
  127.     IF(IFF.NE.0) THEN
  128.     X2=XLN
  129.     Y2=YLN
  130.     ENDIF
  131.     XXA=X1
  132.     YYA=Y1
  133.     XXB=X2
  134.     YYB=Y2
  135.     CALL LINE(XXA,YYA,XXB,YYB,C)
  136.     GOTO 10
  137. 400    WRITE(*,'(1X,22HSelect color (0-255): ,\)')
  138.     READ(*,*)CO
  139.     C=CO
  140.     GOTO 10
  141. 500    WRITE(*,'(1X,15HInput X0,Y0,R: ,\)')
  142.     READ(*,*)XC,YC,RC
  143.     X0=XC
  144.     Y0=YC
  145.     R=RC
  146.     CALL CIRCLE(X0,Y0,R,TH1,TH2,C)
  147.     GOTO 10
  148. 600    CALL CLSG
  149.     CALL DRAWC
  150.     GOTO 10
  151. 700    XCC=XCC+10
  152.     IF(XCC.GE.XW2) XCC=XW1
  153.     GOTO 10
  154. 710    C=C+256
  155.     IR=YM*XB/YB*.2
  156.     X0=XM/2-IR
  157.     Y0=YM*XB/YB/2+20
  158.     Y00=Y0-.866*IR
  159.     R=IR
  160.     CALL CIR(X0,Y0,R,C)
  161.     C=C+1
  162.     X0=X0+IR/2
  163.     CALL CIR(X0,Y00,R,C)
  164.     C=C+1
  165.     X0=X0+IR/2
  166.     CALL CIR(X0,Y0,R,C)
  167.     C=C-256
  168.     GOTO 10
  169. 800    IR=YM*XB/YB*.38
  170.     Y0=10+IR
  171.     X0=XM/2
  172.     DO 820 I=0,15
  173.     C=255-I
  174.     JR=IR
  175.     DO 830 J=1,JR
  176.     R=J
  177.     CALL CIRCLE(X0,Y0,R,TH1,TH2,C)
  178. 830    CONTINUE
  179.     ir=ir-3
  180. 820    continue
  181.     goto 10
  182. 850    R=YM*XB/YB*.1
  183.     X0=20+R
  184.     Y0=YM*XB/YB/2
  185.     X00=X0
  186.     Y00=Y0
  187.     C=C+256
  188.     CALL CIRCLE(X0,Y0,R,TH1,TH2,C)
  189.     X0=X0+1
  190.     JK=(XM-2*R-40)/2
  191.     DO 855 I=1,JK
  192.     CALL CIRCLE(X00,Y0,R,TH1,TH2,C)
  193.     CALL CIRCLE(X0,Y0,R,TH1,TH2,C)
  194.     X00=X0
  195.     X0=X0+2
  196. 855    CONTINUE
  197.     C=C-256
  198.     GOTO 10
  199. 300    IF(ICF.EQ.0)WRITE(*,*)'Error command,repeat input please'
  200.     IF(ICF.NE.0)WRITE(*,*)'├ⁿ┴ε┤φ, ╟δ╓╪╩Σ╚δ !'
  201.     GOTO 10
  202. 200    C=0
  203.     CALL SCREEN(C)
  204.     CALL QUIT
  205. 1000    STOP
  206.     END
  207.     SUBROUTINE CIR(XC,YC,RC,CC)
  208.     INTEGER*2 XC,YC,RC,CC,X1,Y1,X2,Y2
  209.     IP=RC
  210.     Y1=YC+RC
  211.     Y2=YC-RC
  212.     CALL LINE(XC,Y1,XC,Y2,CC)
  213.     DO 1010 I=1,IP
  214.     YL=RC*RC-I*I
  215.     YL=SQRT(YL)
  216.     Y1=YC+YL
  217.     Y2=YC-YL
  218.     X1=XC-I
  219.     X2=XC+I
  220.     CALL LINE(X1,Y1,X1,Y2,CC)
  221.     CALL LINE(X2,Y1,X2,Y2,CC)
  222. 1010    CONTINUE
  223.     RETURN
  224.     END
  225.