'[color=800000]*** QBasic趣味程序——瀑布 ***[/color]
DECLARE FUNCTION getdot% (x%, y%)
DECLARE SUB dot (x%, y%, icolor%)
DECLARE SUB InitDrop (x AS INTEGER, y AS INTEGER)
DECLARE SUB MoveDrop ()
'
'   这个程序演示了通过NEO的基本绘图函数实现的粒子系统——瀑布
'   效果。
'


CONST ParticleNum = 950

TYPE PARTICLE    ' 粒子系统
  
    cx AS SINGLE    ' X座标
    cy AS SINGLE    ' Y座标
    vx AS SINGLE    ' X轴速度
    vy AS SINGLE    ' Y轴速度
    vyacc AS SINGLE ' 加速度
    life AS SINGLE  ' 生命期
    decay AS SINGLE ' 衰减量
  
END TYPE

DIM SHARED gDrop(ParticleNum) AS PARTICLE

'定义屏幕缓冲
DIM scr(32001) AS INTEGER   '
scr(0) = 320 * 8                   '
scr(1) = 200                       '屏幕缓冲
DEF SEG = VARSEG(scr(2))         '
DIM SHARED offs&
offs& = VARPTR(scr(2))           '

DIM i    AS INTEGER
DIM x AS INTEGER
DIM y AS INTEGER
DIM icolor AS INTEGER
SCREEN 13
FOR i = 0 TO 128 ' STEP  i++
  
  'set_color(i, 0, i>>3, i>>1)

  PALETTE i, 256 * CINT(i / 8) + 65536 * (CINT(i / 2) AND 63)
NEXT

DO
  
  '暂定或结束
  k$ = INKEY$
  IF k$ <> "" THEN
    DO
      IF k$ = CHR$(27) THEN EXIT DO
      k$ = INKEY$
    LOOP UNTIL k$ <> ""
    IF k$ = CHR$(27) THEN EXIT DO
  END IF
  
  InitDrop 130, 25
  MoveDrop
  
  FOR i = 0 TO ParticleNum - 1 ' STEP  i++
    dot CINT(gDrop(i).cx), CINT(gDrop(i).cy), 127
    'PSET (gDrop(i).cx, gDrop(i).cy), 127

  NEXT
  
  FOR y = 25 TO 200 - 1  'STEP  y++
    
    FOR x = 130 TO 215 - 1  'STEP  x++
      
      'icolor = (POINT(x, y - 1)) + POINT(x + 1, y) + POINT(x, y + 1) + POINT(x - 1, y)) / 4
      icolor = (getdot%(x, y - 1) + getdot%(x + 1, y) + getdot%(x, y + 1) + getdot%(x - 1, y)) / 4
      
      IF icolor > 2 THEN
        
        'PSET (x, y), icolor - 2
        dot x, y, icolor - 2
      ELSE
        'PSET (x, y), 0
        dot x, y, 0
      END IF
      
    NEXT
  NEXT
'更多QBasic趣味在[url]http://www.hrcgw.com/bbs/[/url]
PUT (0, 0), scr, PSET            '输出到屏幕

'ERASE scr' REDIM scr(32001) AS INTEGER '清屏
'scr(0) = 2560: scr(1) = 200            '
LOOP

SUB dot (x%, y%, icolor%) '写点
  POKE offs& + CLNG(x%) + CLNG(y%) * 320, icolor%
END SUB

FUNCTION getdot% (x%, y%) '获取一个点的颜色
  if x%<0 or x%>319 or y%<0 or y%>199 then
    getdot% = -1
  else
    getdot% = PEEK(offs& + CLNG(x%) + CLNG(y%) * 320)
  endif
END FUNCTION

SUB InitDrop (x AS INTEGER, y AS INTEGER)

DIM i    AS INTEGER

FOR i = 0 TO ParticleNum - 1  ' STEP  i++
  
  IF gDrop(i).life <= 0 THEN
    
    gDrop(i).cx = CSNG(x)
    gDrop(i).cy = CSNG(y)
    gDrop(i).vx = CSNG(.0007 * (RND * 500 + 500))
    gDrop(i).vy = CSNG(.1 * RND * 10)
    gDrop(i).vyacc = .05
    gDrop(i).life = 1!
    gDrop(i).decay = CSNG(.0005 * (RND * 250))
    
  END IF
  
NEXT

END SUB

SUB MoveDrop

DIM i    AS INTEGER

FOR i = 0 TO ParticleNum - 1  'STEP  i++
  
  IF gDrop(i).life > 0 THEN
    
    gDrop(i).cx = gDrop(i).cx + gDrop(i).vx
    gDrop(i).cy = gDrop(i).cy + gDrop(i).vy
    gDrop(i).vy = gDrop(i).vy + gDrop(i).vyacc
    gDrop(i).life = gDrop(i).life - gDrop(i).decay
    IF gDrop(i).cx >= 310 THEN
      
      gDrop(i).vx = gDrop(i).vx * (-1)
    END IF
    
    IF (gDrop(i).cy <= 10) OR (gDrop(i).cy >= 190) THEN
      
      gDrop(i).vy = gDrop(i).vy * (-1)
      gDrop(i).decay = gDrop(i).decay + .1
      gDrop(i).vy = gDrop(i).vy + .1
      
    END IF
    
  END IF
  
NEXT

END SUB