From 7795d6e35e067e54f14ff34a9cf5a2a96c0becb7 Mon Sep 17 00:00:00 2001
From: Jeffrey Armstrong <jeffrey.armstrong@approximatrix.com>
Date: Fri, 6 Jun 2014 10:16:16 -0400
Subject: Initial code commit for Fetris.

---
 main.f90 | 130 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 130 insertions(+)
 create mode 100644 main.f90

(limited to 'main.f90')

diff --git a/main.f90 b/main.f90
new file mode 100644
index 0000000..1d31363
--- /dev/null
+++ b/main.f90
@@ -0,0 +1,130 @@
+program fetris
+use m_game
+use m_screen
+use m_piece
+use m_constants
+use bgi
+implicit none
+
+type(game)::g
+type(piece)::new_p
+logical::playing, loser
+logical::redraw
+integer::last_score
+
+integer(kind=8)::count_rate, count_now
+real(kind=8)::current_time, last_update
+
+    call init_random()
+
+    call init()
+    
+    g = new_game()
+    g%falling = new_piece()
+    g%piece_stuck = .FALSE.
+    
+    call system_clock(count_rate=count_rate)
+    
+    playing = .TRUE.
+    loser = .FALSE.
+    last_update = 0
+    last_score = -1
+    call draw_score(g)
+    
+    do while(playing)
+    
+        call system_clock(count=count_now)
+        current_time = real(count_now, 8)/real(count_rate,8)
+        redraw = .FALSE.
+    
+        if(current_time - last_update .GT. UPDATE_SECONDS) then
+            last_update = current_time
+            call move_piece(g)
+            redraw = .TRUE.
+        end if
+    
+        if(g%piece_stuck) then
+            
+            last_score = g%score
+            call check_rows(g)
+        
+            new_p = new_piece()
+            if(.NOT. check_piece(g, new_p, new_p%r, new_p%c)) then
+                loser = .TRUE.
+                playing = .FALSE.
+                call clear_keys()
+                exit
+            else
+                g%falling = new_p
+                g%piece_stuck = .FALSE.
+                call clear_keys()
+            end if
+        end if
+        
+        if(kbhit() .NE. 0) then
+            select case (getch())
+                case (KEY_LEFT)
+                    call move_piece(g, LEFT)
+                    redraw = .TRUE.
+                case (KEY_RIGHT)
+                    call move_piece(g, RIGHT)
+                    redraw = .TRUE.
+                case (KEY_DOWN)
+                    call move_piece(g, DOWN)
+                    redraw = .TRUE.
+                case (KEY_UP)
+                    call rotate_piece(g)
+                    redraw = .TRUE.
+                case (ichar('q'), ichar('Q'))
+                    playing = .FALSE.
+            end select
+        end if
+        
+        if(redraw) then
+            call draw_board(g)
+            if(g%score .NE. last_score) then
+                call draw_score(g)
+                last_score = g%score
+            end if
+        end if
+    
+    end do
+    
+    if(loser) then
+        call clear_keys()
+        call show_loss(g%score)
+    end if
+    
+    call shutdown()
+
+contains
+
+    subroutine init_random()
+    implicit none
+    INTEGER :: i, n, clock
+    INTEGER, DIMENSION(:), ALLOCATABLE :: seed
+
+        CALL RANDOM_SEED(size = n)
+        ALLOCATE(seed(n))
+
+        CALL SYSTEM_CLOCK(COUNT=clock)
+
+        seed = clock + 37 * (/ (i - 1, i = 1, n) /)
+        CALL RANDOM_SEED(PUT = seed)
+
+        DEALLOCATE(seed)
+    end subroutine init_random
+
+    subroutine clear_keys()
+    use bgi
+    implicit none
+    
+    integer::ignored
+    
+        do while(kbhit() .NE. 0)
+            ignored = getch()
+        end do
+        
+    end subroutine clear_keys
+
+end program fetris
\ No newline at end of file
-- 
cgit v1.2.3