! The asteriods video game clone ! for Fortran 90 or "F" from Imagine1 Inc. ! ! A proof-of-concept exercise calling the X window system from Fortran 90 ! ! Keyboard Controls ! ! e - turn left ! r - turn right ! d - set autorotate left ! f - set autorotate right ! ; - accelerate ! ' - fire bullet ! spacebar - hyperspace jump ! p - pause ! s - New Ship ! q - Quit ! module astmod use xlib use xlib_interface use names implicit none private public :: square, myrand, initasts, makeasts, makeenemy public :: nextast, collide, blastpair, printss, upscore, killast public :: moveobjs, fire, hyper, vdraw public :: rand interface function rand() result(x) integer :: x end function rand end interface type, public :: PolarPair real :: angle integer :: length end type PolarPair ! type, public :: Objtype integer :: shapeo logical :: alive integer :: time real :: x real :: y real :: xvel real :: yvel real :: rot real :: rotvel end type Objtype ! ! /* Indexes for 1st dimension of obj*/ ! /* The order they are in is important*/ ! integer, public, parameter :: AST = 0 integer, public, parameter :: ENEMY = 96 integer, public, parameter :: ENEMYBUL = 97 integer, public, parameter :: FBUL = 98 integer, public, parameter :: LASTBUL = 102 integer, public, parameter :: SHIP = 103 integer, public, parameter :: LASTSHAPE = 103 ! /* Shapes*/ integer, public, parameter :: ASTSHAPE1 = 0 integer, public, parameter :: ASTSHAPE2 = 1 integer, public, parameter :: ASTSHAPE3 = 2 integer, public, parameter :: SHIPSHAPE = 3 integer, public, parameter :: ENEMYSHAPE = 4 integer, public, parameter :: ENBULSH = 5 integer, public, parameter :: BULSHAPE = 6 ! real, public, parameter :: pi = 3.1415926535897932384 integer, public, parameter :: letheight = 20 ! type(Objtype), public, dimension(0:SHIP) :: obj type(PolarPair), public, dimension(0:BULSHAPE,1:11) :: shapes integer, save, public :: width, height, numasts, ships, score integer, save, public :: highscore = 0 integer, save, public :: rndint = 73 integer, save, public :: oldships = -99 integer, save, public :: oldscore = -99 integer, save, public :: nextbul = FBUL integer, public, save, dimension(0:BULSHAPE) :: numpairs = (/ 11, 11, 11, 7, 5, 5, 2 /) integer, public, save, dimension(0:BULSHAPE) :: shapesize = & (/ 44*44, 21*21, 10*10, 28*28, 20*20, 2, 1 /) ! integer(kind=ptrtype), public :: disp integer, public :: window integer(kind=ptrtype), public :: gc, pmgc integer, public :: drw integer, public :: pixmap integer, public :: font type(x_event), public :: event integer, public :: key type(X_Size_Hint_Record), public :: hint integer(kind=ptrtype), public :: screen integer, public :: depth character(len=10), public :: text character(len=1), public :: ch integer, public :: fg, bg ! logical, save, public :: flashon = .false. logical, save, public :: pause = .false. integer, save, public :: delay = 64 real, public :: dx, dy, dist, edel real, public, pointer :: temp ! contains ! function square(x) result (sq) real, intent(in) :: x real :: sq sq = x * x return end function square ! function myrand() result(mr) integer :: mr ! following code commented out because ! "F" won't allow subroutine call from a function !real :: x !x = rand() ! call random_number(x) !mr = int(x * 4194304) mr = rand() return end function myrand ! subroutine initasts() integer :: i shapes(0,1:11) = (/ & PolarPair(0,0), PolarPair(3*pi/2,40), PolarPair(0,20), & PolarPair(pi/4,28), PolarPair(pi/2,40), PolarPair(3*pi/4,28), & PolarPair(pi,40), PolarPair(5*pi/4,28), PolarPair(3*pi/2,40), & PolarPair(7*pi/4,28), PolarPair(0,20) /) ! shapes(1,1:11) = (/ & PolarPair(0,0), PolarPair(3*pi/2,20), PolarPair(0,10), & PolarPair(pi/4,14), PolarPair(pi/2,20), PolarPair(3*pi/4,14), & PolarPair(pi,20), PolarPair(5*pi/4,14), PolarPair(3*pi/2,20), & PolarPair(7*pi/4,14), PolarPair(0,10) /) ! shapes(2,1:11) = (/ & PolarPair(0,0), PolarPair(3*pi/2,10), PolarPair(0,5), & PolarPair(pi/4,7), PolarPair(pi/2,10), PolarPair(3*pi/4,7), & PolarPair(pi,10), PolarPair(5*pi/4,7), PolarPair(3*pi/2,10), & PolarPair(7*pi/4,7), PolarPair(0,5) /) ! shapes(3,1:7) = (/ & PolarPair(0,0), PolarPair(5*pi/4,28), PolarPair(0,20), & PolarPair(pi/4,28), PolarPair(3*pi/4,28), PolarPair(pi,20), & PolarPair(7*pi /4,28) /) ! shapes(4,1:5) = (/ & PolarPair(0,0), PolarPair(pi,20), PolarPair(7*pi/4,28), & PolarPair(pi/4,28), PolarPair(pi,20) /) ! shapes(5,1:5) = (/ & PolarPair(0,0), PolarPair(7*pi/4, 4), PolarPair(pi/4, 4), & PolarPair(3*pi/4, 4), PolarPair(5*pi/4, 4) /) ! shapes(6,1:2) = (/ PolarPair(0,0), PolarPair(0,10) /) ! do i=0,LASTSHAPE obj(i) % rot = 0 obj(i) % rotvel = 0 enddo do i=0,ENEMY-1 obj(i) % shapeo = ASTSHAPE1 enddo obj(ENEMY) % shapeo = ENEMYSHAPE obj(SHIP) % shapeo = SHIPSHAPE obj(ENEMYBUL) % shapeo = ENBULSH do i=FBUL, LASTBUL obj(i) % shapeo = BULSHAPE enddo ! return end subroutine initasts ! subroutine makeasts(level) integer, intent(in) :: level integer :: i, a do i=0,LASTSHAPE obj(i) % alive = .false. enddo do i=ENEMYBUL,LASTBUL obj(i) % time = 0 enddo do i=0,level+2 a = modulo(myrand(), 128) if(a > 63) then obj(i) % x = real(a) else obj(i) % x = real(width - a) endif a = modulo(myrand(), 128) if(a > 63) then obj(i) % y = real(a) else obj(i) % y = real(height - a) endif a = 4 - modulo(myrand(), 8) obj(i) % rot = real(a) obj(i) % rotvel = real(modulo(myrand(),4))/ 10.0 - 0.12 a = 4 - modulo(myrand(), 8) obj(i) % xvel = cos(real(a)-0.5) obj(i) % yvel = sin(real(a)-0.5) obj(i) % shapeo = ASTSHAPE1 obj(i) % alive = .true. enddo numasts = level + 3 end subroutine makeasts ! subroutine makeenemy(level) integer, intent(in) :: level obj(ENEMY) % alive = .true. obj(ENEMY) % x = 0 obj(ENEMY) % y = real (height / 4) obj(ENEMY) % y = obj(ENEMY) % y + real(modulo(myrand(), 256)) obj(ENEMY) % xvel = real(level) / 2.0 obj(ENEMY) % yvel = 0.0 end subroutine makeenemy ! function nextast () result (i) integer :: i i = 0 do i = i + 1 if ( .not. obj(i) % alive) then exit endif enddo end function nextast ! function collide(i,j) result(coll) integer, intent(in) :: i, j logical :: coll integer :: diff, xd, yd xd = obj(i) % x - obj(j) % x yd = obj(i) % y - obj(j) % y diff = xd * xd + yd * yd coll = ( diff < (shapesize(obj(i)%shapeo) + shapesize(obj(j)%shapeo))) end function collide ! subroutine blastpair(i,j) !Generate random velocity vector v integer, intent(in) :: i, j integer :: c real :: vx,vy c = myrand() / 32 vx = cos(real(c)) vy = sin(real(c)) obj(i) % xvel = obj(i) % xvel + vx obj(i) % yvel = obj(i) % yvel + vy obj(j) % xvel = obj(j) % xvel - vx obj(j) % yvel = obj(j) % yvel - vy obj(i) % rotvel = obj(i) % rotvel + 0.05 obj(j) % rotvel = obj(j) % rotvel - 0.05 end subroutine blastpair ! subroutine printss() character(len=21) :: sstring if ( score /= oldscore) then if (( score / 10000) > (oldscore / 10000)) then ships = ships + 1 endif if (( score / 10000) < (oldscore / 10000)) then ships = ships - 1 if ( ships == 0) then obj(SHIP) % alive = .false. endif endif if ( score > highscore) then sstring = " " highscore = score write(unit=sstring, fmt=*) "High score: ",highscore call x_draw_image_string(disp, window, gc, 330, height+letheight, & sstring) endif sstring = " " write(unit=sstring, fmt=*) "Score: ",score call x_draw_image_string(disp, window, gc, 110, height+letheight, & sstring) oldscore = score endif if ( ships /= oldships ) then sstring = " " write(unit=sstring, fmt=*) "Ships: ",ships call x_draw_image_string(disp, window, gc, 1, height+letheight, & sstring(1:12)) oldships = ships endif end subroutine printss ! subroutine upscore(killer, up) integer, intent(in) :: killer, up if( killer /= ENEMYBUL .and. killer /= SHIP) then score = score + up endif end subroutine upscore ! subroutine killast(killer, i) integer, intent(in) :: killer, i integer :: k, na, oldna if( obj(i) % shapeo == ASTSHAPE1 ) then na = nextast() obj(na) % x = obj(i) % x obj(na) % y = obj(i) % y obj(na) % xvel = obj(i) % xvel obj(na) % yvel = obj(i) % yvel obj(na) % alive = .true. obj(na) % shapeo = ASTSHAPE2 obj(i) % shapeo = ASTSHAPE2 call blastpair(i, na) numasts = numasts + 1 call upscore(killer, 25) ! else if (obj(i) % shapeo == ASTSHAPE2 ) then do k=1,3 oldna = na na = nextast() obj(na) % x = obj(i) % x obj(na) % y = obj(i) % y obj(na) % xvel = obj(i) % xvel obj(na) % yvel = obj(i) % yvel obj(na) % alive = .true. obj(na) % shapeo = ASTSHAPE3 if(k == 2) then call blastpair(oldna, na) endif enddo obj(i) % shapeo = ASTSHAPE3 call blastpair(na, i) numasts = numasts + 3 obj(na) % alive = .true. call upscore(killer, 50) else if (obj(i) % shapeo == ASTSHAPE3 ) then obj(i) % alive = .false. numasts = numasts - 1 call upscore(killer, 100) else obj(i) % alive = .false. call upscore(killer, 500) endif end subroutine killast ! subroutine moveobjs(crash) integer, intent (inout) :: crash integer :: i, j real :: temp crash = 0 do i=0,LASTSHAPE if(obj(i) % alive) then temp = obj(i) % x temp = temp + obj(i) % xvel do ! ! while (temp < 0) if (temp >= 0) then exit endif temp = temp + width enddo do ! while (temp > width) if (temp <= width) then exit endif temp = temp - width enddo obj(i) % x = temp temp = obj(i) % y temp = temp + obj(i) % yvel do ! while (temp < 0) if (temp >= 0) then exit endif temp = temp + height enddo do ! while (temp > height) if (temp <= height) then exit endif temp = temp - height enddo obj(i) % y = temp obj(i) % rot = obj(i) % rot + obj(i) % rotvel endif enddo do i=0,FBUL-1 if(obj(i) % alive) then if(obj(SHIP) % alive .and. collide(i, SHIP)) then crash = 2 ships = ships - 1 obj(SHIP) % alive = .false. call killast(SHIP, i) endif do j= ENEMYBUL, LASTBUL if(obj(j) % alive .and. collide(i,j) .and. & (j /= ENEMYBUL .or. (i /= ENEMYBUL .and. i /= ENEMY))) then obj(j) % alive = .false. call killast(j,i) endif enddo endif enddo end subroutine moveobjs ! subroutine fire() real :: shiprot, cosrot, sinrot ! obj(nextbul) % alive = .true. !write(unit=*,fmt=*) " fire ", nextbul shiprot = obj(SHIP) % rot cosrot = cos(shiprot) sinrot = sin(shiprot) obj(nextbul) % x = obj(SHIP) % x + 20.0 * cosrot obj(nextbul) % y = obj(SHIP) % y + 20.0 * sinrot obj(nextbul) % xvel = obj(SHIP) % xvel + 10 * cosrot obj(nextbul) % yvel = obj(SHIP) % yvel + 10 * sinrot obj(nextbul) % rot = shiprot obj(nextbul) % time = width / 11 nextbul = nextbul + 1 if(nextbul > LASTBUL) then nextbul = FBUL endif end subroutine fire ! subroutine hyper() integer :: i i = modulo(myrand(), 1024) do !while(i > width) if (i <= width) then exit endif i = i - width enddo obj(SHIP) % x = real(i) i = modulo(myrand(), 1024) do !while(i > height) if (i <= height) then exit endif i = i - height enddo obj(SHIP) % y = real(i) end subroutine hyper ! subroutine vdraw( shapeo, x, y, rot) integer, intent(in) :: shapeo, x, y real, intent(in) :: rot integer :: line ! type(Point), dimension(0:20) :: figure ! figure(0) % x = x figure(0) % y = y do line = 1, numpairs(shapeo) figure(line) % x = shapes(shapeo, line) % length * & cos(shapes(shapeo, line) % angle + rot) figure(line) % y = shapes(shapeo, line) % length * & sin(shapes(shapeo, line) % angle + rot) enddo call x_draw_lines (disp, pixmap, gc, figure, numpairs(shapeo)+1, & CoordModePrevious) ! end subroutine vdraw ! end module astmod program asteroids use xlib use xlib_interface use names use chars use astmod implicit none integer :: i, level, crashed, lens, enemycount, c ! ! ! Start of executable code ! disp = x_open_display("") screen = default_screen(disp) bg = black_pixel(disp, screen) fg = white_pixel(disp, screen) hint % x = 150 hint % y = 200 hint % width = 650 hint % height = 550 hint % flags = Program_Specified_Position + Program_Specified_Size width = hint % width height = hint % height - letheight - 1 depth = default_depth (disp, screen) drw = default_root_window(disp) window = x_create_simple_window (disp, drw, & hint%x, hint%y, hint%width, hint%height, 5, fg, bg) pixmap = x_create_pixmap (disp, window, width, height, depth) call x_set_standard_properties (disp, window, "asteroids", "asteroids", 0, & hint) gc = x_create_gc (disp, window, 0) call x_set_graphics_exposures(disp, gc, .true.) font = x_load_font(disp, "9x15") call x_set_font(disp, gc, font) pmgc = x_create_gc (disp, window, 0) call x_set_background (disp, gc, bg) call x_set_foreground (disp, gc, fg) call x_set_foreground (disp, pmgc, bg) call x_select_input (disp, window, KeyPressMask + StructureNotifyMask) call x_map_raised (disp, window) ! call initasts() newgame: do !write(unit=*,fmt="("" New Game "")") ships = 3 score = 0 call x_sync(disp, .false.) level = 0 levels: do numasts = 0 level = min(8, level+1) call makeasts (level) newship: do !write(unit=*,fmt="("" New Ship "")") obj(SHIP) % alive = .true. obj(SHIP) % x = width/2 obj(SHIP) % y = height/2 obj(SHIP) % xvel = 0 obj(SHIP) % yvel = 0 obj(SHIP) % rot = 3.0 * pi/2.0 obj(SHIP) % rotvel = 0 crashed = 0 flashon = .false. enemycount = 20 number_of_asts: do !while (numasts > 0) if ( numasts <= 0 ) then exit endif do i=FBUL,LASTBUL if (obj(i) % alive) then obj(i) % time = obj(i) % time - 1 if(obj(i) % time <= 0) then obj(i) % alive = .false. endif endif enddo eventloop: do if ( x_events_queued(disp, QueuedAfterReading) == 0 ) then exit eventloop else call x_next_event(disp, event) !Event_case: select case(event % type) select case(event % event_type) case(MappingNotify) call x_refresh_keyboard_mapping(event) case(ConfigureNotify) width = event % event_data(8) height = event % event_data(9) - letheight - 1 call x_free_pixmap(disp, pixmap) pixmap = x_create_pixmap (disp, window, width, height, depth) oldships = -99 case(KeyPress) call x_lookup_string (event, text, 10, key, 0, lens) ch = text(1:1) if(lens == 1 ) then !keypressed: select case(ch) select case(ch) case("e") obj(SHIP) % rot = obj(SHIP) % rot - 0.2 case("r") obj(SHIP) % rot = obj(SHIP) % rot + 0.2 case("d") obj(SHIP) % rotvel = obj(SHIP) % rotvel - 0.2 case("f") obj(SHIP) % rotvel = obj(SHIP) % rotvel + 0.2 case(";") !thrust obj(SHIP) % xvel = obj(SHIP) % xvel + cos(obj(SHIP)%rot) obj(SHIP) % yvel = obj(SHIP) % yvel + sin(obj(SHIP)%rot) case("'") if(obj(SHIP) % alive) then call fire() endif case(" ") if(obj(SHIP) % alive) then call hyper() endif case("p") pause = .not. pause oldships = -99 case("q") exit newgame case("s") if(.not. obj(SHIP) % alive) then if(ships /= 0) then cycle newship ! New Ship else cycle newgame ! New Game endif endif end select ! keypressed endif !case default ! print*," ast default event%type ",event%type end select ! event_case endif enddo eventloop if( .not. pause ) then call moveobjs(crashed) if(crashed == 2) then crashed = crashed - 1 flashon = .true. endif do i=0,LASTSHAPE if(obj(i) % alive) then call vdraw(obj(i) % shapeo, int(obj(i) % x), & int(obj(i) % y), obj(i) % rot) endif enddo ! update display if(ships /= 0) then score = score - 1 endif call x_copy_area (disp, pixmap, window, gc, 0, 0, width, height, 0, 0) call x_fill_rectangle (disp, pixmap, pmgc, 0, 0, width, height) if(flashon) then flashon = .false. endif call x_sync(disp, .false.) c = modulo(myrand(), 256) if(.not. obj(ENEMY) % alive)then if(c < level) then c = modulo(myrand(), 256) if (c < (level-1)*10) then call makeenemy(level) endif endif else edel = -0.5 if(c > int(128.0 + 6.0 * obj(ENEMY) % yvel)) then edel = 0.5 endif obj(ENEMY) % yvel = obj(ENEMY) % yvel + edel endif enemycount = enemycount - 1 if(enemycount == 0) then enemycount = 100 if(obj(ENEMY) % alive) then obj(ENEMYBUL) % alive = .true. obj(ENEMYBUL) % x = obj(ENEMY) % x obj(ENEMYBUL) % y = obj(ENEMY) % y dx = obj(SHIP) % x - obj(ENEMY) % x dy = obj(SHIP) % y - obj(ENEMY) % y dist = sqrt(square(dx) + square(dy)) obj(ENEMYBUL) % xvel = 3.0 * dx / dist obj(ENEMYBUL) % yvel = 3.0 * dy / dist else obj(ENEMYBUL) % alive = .false. endif endif call printss() endif enddo number_of_asts exit enddo newship enddo levels exit enddo newgame ! write(unit=*,fmt=*) "Your high score was ",highscore call x_free_gc (disp, gc) call x_free_gc (disp, pmgc) call x_free_pixmap (disp, pixmap) call x_destroy_window (disp, window) call x_close_display (disp) stop ! " end of program " ! end program asteroids