BBC BASIC Programmers' Reference

This page is read only. You can view the source, but not change it. Ask your administrator if you think this is wrong.
<code bb4w>
      ON ERROR OSCLI "refresh on" : IF ERR=17 CHAIN @lib$+"../examples/tools/touchide" ELSE MODE 3 : PRINT REPORT$ : END

      REM  Torus 2
      REM  Version 1.2 // 16-Mar-2012
      REM  Original BB4W/GFXLIB program by David Williams
      REM  BBCSDL/GFX2DLIB adaptation by Richard Russell.

      REM  Prevent the program window from being resized by the user
      IF @platform% >= &2050000 SYS "SDL_SetWindowResizable", @hwnd%, FALSE

      REM  Select a 640x512 display mode and switch off the flashing cursor
      MODE 8
      OFF

      REM  Initialise 2D graphics
      PROC_init2D

      REM  Install and initialise SORTLIB (which will be used to depth-sort the
      REM  'vector balls' according to their Z coordinate)
      INSTALL @lib$ + "sortlib"
      sort%% = FN_sortinit(1, 0)

      REM  Load-in the ball sprite (20x20 pixels)
      ballSprite = FN_loadBMP( @dir$ + "ball3_20x20.bmp", 0 )

      REM  Define torus vars
      ballsPerRing% = 12
      ringRadius% = 20
      ringDist% = 56
      numRings% = 32
      numBalls% = numRings% *  ballsPerRing%

      REM  Array to hold the balls' positions in '3D space'
      DIM p(2, numBalls% - 1)

      REM  Array to hold the balls' positions *after* they've been rotated
      DIM q(2, numBalls% - 1)

      REM  Arrays to hold each ball's ``normal vector``
      DIM n(2, numBalls% - 1)

      REM  Arrays to hold each ball's rotated normal vector
      DIM o(2, numBalls% - 1)

      REM  Rotation matrices
      DIM a(2,2), b(2,2), c(2,2), r(2,2)

      REM  Define our 'light source' direction vector
      DIM light(2)
      light() = 20, 5, -10
      light() /= MOD(light())

      REM  Set up a horizontally-scrolling starfield (four pixels per star)
      numStars% = 100
      DIM sx( numStars%-1 ), sy( numStars%-1 ), dx( numStars%-1 )
      DIM pt{( numStars%*4-1 ) x%, y%}

      FOR I% = 0 TO numStars%-1
        sx( I% ) = 640.0 * RND(1)
        sy( I% ) = 48 + (512.0 - 2*48) * RND(1)
        dx( I% ) = 0.5 + 3.5*I%/numStars% - 0.5*RND(1)
      NEXT I%

      REM  Define our 3D torus object
      N% = 0

      FOR T% = 0 TO numRings%-1

        FOR A% = 0 TO ballsPerRing%-1

          x = ringDist% + ringRadius% * SIN( A% * 2*PI/ballsPerRing% )
          y = ringRadius% * COS( A% * 2*PI/ballsPerRing% )
          z = 0.0

          nx = 1.0 * SIN( A% * 2*PI/ballsPerRing% )
          ny = 1.0 * COS( A% * 2*PI/ballsPerRing% )
          nz = 0.0

          PROCrotate( x, y, z,    0, T%*(2*PI/numRings%), 0, x`, y`, z` )

          PROCrotate( nx, ny, nz, 0, T%*(2*PI/numRings%), 0, nx`, ny`, nz` )

          p( 0, N% ) = x`
          p( 1, N% ) = y`
          p( 2, N% ) = z`

          n( 0, N% ) = nx`
          n( 1, N% ) = ny`
          n( 2, N% ) = nz`

          N% += 1

        NEXT A%

      NEXT T%

      a = 2.0 * PI*RND(1) : REM  \
      b = 2.0 * PI*RND(1) : REM   >---  rotation angles
      c = 2.0 * PI*RND(1) : REM  /

      REM  Disable automatic program window refresh
      *REFRESH OFF

      REPEAT

        REM  Clear the viewport
        PROC_clr2D(0, 0, 0)

        REM  Update star positions
        FOR I% = 0 TO numStars%-1
          IF sx(I%) > 640 sx(I%) -= 640
          pt{( I%*4 )}.x% = sx(I%) + 0.5
          pt{( I%*4 )}.y% = sy(I%) + 0.5
          pt{(I%*4+1)}.x% = sx(I%) + 1.5
          pt{(I%*4+1)}.y% = sy(I%) + 0.5
          pt{(I%*4+2)}.x% = sx(I%) + 0.5
          pt{(I%*4+2)}.y% = sy(I%) + 1.5
          pt{(I%*4+3)}.x% = sx(I%) + 1.5
          pt{(I%*4+3)}.y% = sy(I%) + 1.5
        NEXT
        sx() += dx()

        REM  Draw stars (four pixels per star)
        PROC_pixels2D(pt{(numStars%*0)}, numStars%, &40, &40, &40, &FF)
        PROC_pixels2D(pt{(numStars%*1)}, numStars%, &80, &80, &80, &FF)
        PROC_pixels2D(pt{(numStars%*2)}, numStars%, &C0, &C0, &C0, &FF)
        PROC_pixels2D(pt{(numStars%*3)}, numStars%, &FF, &FF, &FF, &FF)

        REM  Draw upper and lower blue borders
        FOR Y% = 0 TO 47
          C% = 255*(1 - Y%/47)
          PROC_rect2D(0, Y%, 640, 1, 0, 0, C%, &FF)
          PROC_rect2D(0, 511-Y%, 640, 1, 0, 0, C%, &FF)
        NEXT

        REM  Create the rotation matrix
        a() = 1, 0, 0, 0, COS(a), -SIN(a), 0, SIN(a), COS(a)
        b() = COS(b), 0, SIN(b), 0, 1, 0, -SIN(b), 0, COS(b)
        c() = COS(c), -SIN(c), 0, SIN(c), COS(c), 0, 0, 0, 1
        r() = b() . a()
        r() = c() . r()

        REM  Rotate the 3D positions of the balls
        REM  (and also rotate the normal vectors)
        q() = r() . p()
        o() = r() . n()

        REM  Sort the rotated ball positions according to their Z-coordinate
        C% = numBalls%
        CALL sort%%, q(2,0), q(1,0), q(0,0), o(2,0), o(1,0), o(0,0)

        REM  ===========================
        REM  Draw the depth-sorted balls
        REM  ===========================

        FOR I%=0 TO numBalls%-1

          REM  Calc. perspective factor
          z = 280 / (200 + q(2,I%))

          REM  Calc. 2D viewport coordinates
          X% = 304 + q(0,I%)*z
          Y% = 240 + q(1,I%)*z

          REM  Calc. angle between the ball's normal vector,
          REM  and light source vector
          l_dot_n = light(0)*o(0,I%) + light(1)*o(1,I%) + light(2)*o(2,I%)
          IF l_dot_n < 0 l_dot_n = 0
          l_dot_n = 0.5 + l_dot_n / 2

          REM  Plot the ball sprite ('tinting' it white in real-time!)
          PROC_plot2D(ballSprite, 20, 20, X%, Y%, &FF*l_dot_n, &FF*l_dot_n, &FF*l_dot_n, &FF, FALSE, FALSE, FALSE)

        NEXT

        REM  Increment and check the rotation angles
        a += 0.0292710182113
        b += 0.0263168891711
        c += 0.0221941538383

        IF a > 2*PI THEN a -= 2*PI
        IF b > 2*PI THEN b -= 2*PI
        IF c > 2*PI THEN c -= 2*PI

        REM  Update the screen (program window)
        *REFRESH

      UNTIL FALSE

      DEF PROCrotate( x, y, z, a, b, c, RETURN x3, RETURN y3, RETURN z3 )
      LOCAL x1, y1, z1, x2, y2, z2
      LOCAL ca, cb, cc, sa, sb, sc

      ca = COSa
      cb = COSb
      cc = COSc
      sa = SINa
      sb = SINb
      sc = SINc

      REM X rotation
      y1 = y*ca - z*sa
      z1 = y*sa + z*ca
      x1 = x

      REM Y rotation
      z2 = z1*cb - x1*sb
      x2 = z1*sb + x1*cb
      y2 = y1

      REM Z rotation
      x3 = x2*cc - y2*sc
      y3 = x2*sc + y2*cc
      z3 = z2
      ENDPROC

      REM High(ish)-performance 2D graphics library

      DEF PROC_init2D
      PIXELFORMAT = &16362004
      `SDL_SetRenderDrawColor`  = FN_gpa("SDL_SetRenderDrawColor")
      `SDL_SetTextureAlphaMod`  = FN_gpa("SDL_SetTextureAlphaMod")
      `SDL_SetTextureColorMod`  = FN_gpa("SDL_SetTextureColorMod")
      `SDL_SetTextureBlendMode` = FN_gpa("SDL_SetTextureBlendMode")
      `SDL_RenderDrawPoints`    = FN_gpa("SDL_RenderDrawPoints")
      `SDL_RenderFillRect`      = FN_gpa("SDL_RenderFillRect")
      `SDL_RenderClear`         = FN_gpa("SDL_RenderClear")
      `SDL_RenderCopy`          = FN_gpa("SDL_RenderCopy")
      `SDL_RenderCopyEx`        = FN_gpa("SDL_RenderCopyEx")
      ENDPROC

      DEF FN_loadBMP(path$, K%)
      LOCAL R%, s%%, t%%
      SYS "SDL_RWFromFile", path$, "rb" TO R%
      IF R%=0 ERROR 103, "Unable to load " + path$
      SYS "SDL_LoadBMP_RW", R%, 1 TO s%%
      IF s%%=0 ERROR 104, "Unable to create surface from " + path$
      IF K%<>TRUE SYS "SDL_SetColorKey", s%%, 1, K%
      SYS "SDL_ConvertSurfaceFormat", s%%, PIXELFORMAT, 0 TO t%%
      SYS "SDL_FreeSurface", s%% : s%% = t%%
      SYS "SDL_CreateTextureFromSurface", @memhdc%, s%% TO t%%
      IF t%%=0 ERROR 105, "Unable to create texture from " + path$
      SYS "SDL_FreeSurface", s%%
      = t%%

      DEF PROC_clr2D(R%,G%,B%)
      SYS `SDL_SetRenderDrawColor`,@memhdc%,R%,G%,B%,&FF
      SYS `SDL_RenderClear`,@memhdc%
      ENDPROC

      DEF PROC_plot2D(t%%,W%,H%,X%,Y%,R%,G%,B%,A%,M%,F%,a)
      LOCAL rc{} : DIM rc{x%,y%,w%,h%}
      rc.x% = X% - W%/2
      rc.y% = Y% - H%/2
      rc.w% = W%
      rc.h% = H%
      IF A%<>&FF SYS `SDL_SetTextureColorMod`,t%%,A%
      IF R%<>&FF OR G%<>&FF OR B%<>&FF SYS `SDL_SetTextureColorMod`,t%%,R%,G%,B%
      IF M% SYS `SDL_SetTextureBlendMode`,t%%,M%
      IF a<>0 OR F% THEN
        IF @platform% AND &40 THEN
          SYS `SDL_RenderCopyEx`,@memhdc%,t%%,FALSE,rc{},FN_nz(a),FALSE,F%
        ELSE
          SYS `SDL_RenderCopyEx`,@memhdc%,t%%,FALSE,rc{},FN_dl(a),FN_dh(a),FALSE,F%
        ENDIF
      ELSE
        SYS `SDL_RenderCopy`,@memhdc%,t%%,FALSE,rc{}
      ENDIF
      IF M% SYS `SDL_SetTextureBlendMode`,t%%,FALSE
      IF R%<>&FF OR G%<>&FF OR B%<>&FF SYS `SDL_SetTextureColorMod`,t%%,&FF,&FF,&FF
      IF A%<>&FF SYS `SDL_SetTextureColorMod`,t%%,&FF
      ENDPROC

      DEF PROC_rect2D(X%,Y%,W%,H%,R%,G%,B%,A%)
      LOCAL rc{} : DIM rc{x%,y%,w%,h%}
      rc.x% = X%
      rc.y% = Y%
      rc.w% = W%
      rc.h% = H%
      SYS `SDL_SetRenderDrawColor`,@memhdc%,R%,G%,B%,A%
      SYS `SDL_RenderFillRect`,@memhdc%,rc{}
      ENDPROC

      DEF PROC_pixels2D(p%%,N%,R%,G%,B%,A%)
      SYS `SDL_SetRenderDrawColor`,@memhdc%,R%,G%,B%,A%
      SYS `SDL_RenderDrawPoints`,@memhdc%,p%%,N%
      ENDPROC

      DEF FN_gpa(p$)
      IF @platform% AND &40 THEN
        LOCAL P%, p%%
        DIM p%% LOCAL 8
        P% = p%% + !340 - PAGE
        [OPT 0:equq p$:]
        = ]p%%
      ENDIF
      LOCAL P%
      DIM P% LOCAL 8
      [OPT 0:nop:]
      CASE P%?-1 OF
        WHEN &90: [OPT 0:call p$:] = P% + P%!-4
        WHEN &E1: [OPT 0:equd p$:] = P%!-4
      ENDCASE
      = FALSE

      DEF FN_dl(a#)=!^a#

      DEF FN_dh(a#)=!(^a#+4)

      DEF FN_nz(a#) a#*=1.0:IFa#=0 ?(^a#+7)=&80
      = a#
</code>