File: main.f03

package info (click to toggle)
cloc 2.06-1
  • links: PTS, VCS
  • area: main
  • in suites: forky, sid
  • size: 8,064 kB
  • sloc: perl: 30,146; cpp: 1,219; python: 623; ansic: 334; asm: 267; makefile: 244; sh: 186; sql: 144; java: 136; ruby: 111; cs: 104; pascal: 52; lisp: 50; haskell: 35; f90: 35; cobol: 35; objc: 25; php: 22; javascript: 15; fortran: 9; ml: 8; xml: 7; tcl: 2
file content (359 lines) | stat: -rw-r--r-- 12,940 bytes parent folder | download
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
! Measure units:
! - *_px - pixels
! - *_cl - cells
! - *_rl - relative (fraction of width, height, cell size, etc)

program main
  use iso_c_binding, only: c_int, c_int32_t, C_NULL_CHAR, C_NULL_PTR, c_loc
  use raylib
  use raymath
  use game
  use ai
  use ui
  implicit none

  type :: Particle
     real, dimension(2) :: position, velocity
     integer(c_int32_t) :: color
     real :: size, lt_sec, lt_t
  end type Particle

  integer, parameter :: font_size = 128
  real,    parameter :: particle_min_mag      = 50.0
  real,    parameter :: particle_max_mag      = 400.0
  real,    parameter :: particle_min_size     = 2.0
  real,    parameter :: particle_max_size     = 5.0
  real,    parameter :: particle_min_lt       = 0.5
  real,    parameter :: particle_max_lt       = 0.8
  integer, parameter :: particles_burst_count = 100

  real    :: dt
  real    :: board_x_px, board_y_px, board_boundary_width, board_boundary_height, board_size_px, cell_size_px

  integer,dimension(board_size_cl, board_size_cl) :: board

  integer :: current_player
  type(TLine) :: final_line
  integer :: state
  type(Font) :: game_font
  type(Particle) :: particles(particles_burst_count*board_size_cl*board_size_cl + 10)
  type(Sound) :: click_sound
  logical :: click_played_on_previous_frame, click_played_on_this_frame

  logical, dimension(2) :: ai_checkboxes
  integer :: i

  enum, bind(C)
     enumerator :: STATE_GAME = 0
     enumerator :: STATE_WON
     enumerator :: STATE_TIE
  end enum

  ai_checkboxes(CELL_CROSS) = .false.
  ai_checkboxes(CELL_KNOTT) = .true.
  do i=1,size(particles)
     particles(i)%lt_t = 0.0
  end do

  call restart_game()

  call set_config_flags(FLAG_WINDOW_RESIZABLE)
  ! TODO: draw_rectangle_rounded, draw_circle_v, etc (basically anything that renders circles) has rendering artifacts that make some of the pixels of the background visible when FLAG_MSAA_4X_HINT is enabled
  ! This could be a bug of Raylib. The implementations may not be taking MSAA into account.
  call set_config_flags(FLAG_MSAA_4X_HINT)
  call init_window(16*80, 9*80, "Fortran GOTY"//C_NULL_CHAR)
  call init_audio_device()
  call set_target_fps(60)

  ! TODO: set the working directory to where the executable is located
  ! This is needed to be able to locate the assets properly
  game_font = load_font_ex("./fonts/Alegreya-Regular.ttf"//C_NULL_CHAR, font_size, C_NULL_PTR, 0)
  call set_texture_filter(game_font%texture, TEXTURE_FILTER_BILINEAR)
  click_sound = load_sound("./sounds/misc_26_fixed.ogg"//C_NULL_CHAR)

  do while (.not. window_should_close())
     click_played_on_previous_frame = click_played_on_this_frame
     click_played_on_this_frame = .false.
     call begin_drawing()
       call begin_screen_fitting()
         call clear_background(background_color)

         dt = get_frame_time()
         board_boundary_width  = screen_width_px*2/3
         board_boundary_height = screen_height_px

         if (board_boundary_width > board_boundary_height) then
            board_size_px = board_boundary_height
            board_x_px = real(board_boundary_width)/2 - board_size_px/2
            board_y_px = 0
         else
            board_size_px = board_boundary_width
            board_x_px = 0
            board_y_px = real(board_boundary_height)/2 - board_size_px/2
         end if

         board_x_px = board_x_px + board_size_px*board_margin_rl
         board_y_px = board_y_px + board_size_px*board_margin_rl
         board_size_px = board_size_px - board_size_px*board_margin_rl*2

         cell_size_px = board_size_px/board_size_cl

         select case (state)
         case (STATE_GAME)
            call render_game_state()
         case (STATE_WON)
            call render_won_state()
         case (STATE_TIE)
            call render_tie_state()
         end select

         call render_ai_checkboxes(rectangle( &
              board_boundary_width, &
              0, &
              screen_width_px - board_boundary_width, &
              board_boundary_height))
       call end_screen_fitting()
     call end_drawing()
  end do

contains
  pure function lerp(a, b, t) result(c)
    real, intent(in) :: a, b, t
    real :: c
    c = a + (b - a)*t
  end function lerp

  subroutine spawn_random_particles_along_line(start, end, count, color)
    real, dimension(2),  intent(in) :: start, end
    integer,             intent(in) :: count
    integer(c_int32_t),  intent(in) :: color

    real, dimension(2) :: position
    real :: t
    integer :: i

    do i=1,count
       call random_number(t)
       position = start + (end - start)*t
       call spawn_random_particle_at(position, color)
    end do
  end subroutine spawn_random_particles_along_line

  subroutine spawn_random_particles_in_region(region, count, color)
    type(Rectangle),intent(in) :: region
    integer,intent(in) :: count
    integer(c_int32_t),intent(in) :: color

    real, dimension(2) :: position, t
    integer :: i

    do i=1,count
       call random_number(t)
       position = [region%x, region%y] + [region%width, region%height]*t
       call spawn_random_particle_at(position, color)
    end do
  end subroutine spawn_random_particles_in_region

  subroutine spawn_random_particle_at(position,color)
    real, dimension(2), intent(in) :: position
    integer(c_int32_t), intent(in) :: color

    type(Particle) :: p
    real :: angle, mag, t
    real, parameter :: pi = 4.D0*DATAN(1.D0)

    p%position = position

    call random_number(t)
    angle = 2.0*pi*t

    call random_number(t)
    mag = lerp(particle_min_mag, particle_max_mag, t)
    p%velocity = [cos(angle), sin(angle)]*mag

    p%color = color

    call random_number(t)
    p%size = lerp(particle_min_size, particle_max_size, t)

    call random_number(t)
    p%lt_sec = lerp(particle_min_lt, particle_max_lt, t)
    p%lt_t = 1.0

    call spawn_particle(p)
  end subroutine spawn_random_particle_at

  subroutine spawn_particle(p)
    type(Particle),intent(in) :: p
    type(Particle) :: pi
    integer :: i

    do i=1,size(particles)
       pi = particles(i)
       if (pi%lt_t <= 0.0) then
          particles(i) = p
          return
       end if
    end do
  end subroutine spawn_particle

  subroutine render_particles(dt)
    real,intent(in) :: dt
    type(Particle) :: p
    integer :: i

    do i=1,size(particles)
       p = particles(i)
       if (p%lt_t > 0.0) then
          particles(i)%velocity = p%velocity*0.98
          particles(i)%position = p%position + particles(i)%velocity*dt
          particles(i)%lt_t = (p%lt_t*p%lt_sec - dt)/p%lt_sec
          call draw_circle_v(Vector2(p%position), p%size, color_alpha(p%color, p%lt_t))
       end if
    end do
  end subroutine render_particles

  subroutine render_ai_checkboxes(boundary)
    real,parameter :: checkbox_width_rl = 0.45
    real,parameter :: checkbox_height_rl = 0.10
    real,parameter :: checkbox_padding_rl = 0.05
    type(Rectangle),intent(in) :: boundary

    type(Rectangle) :: cross_boundary, knott_boundary
    real :: checkbox_height_px, checkbox_padding_px
    type(Vector2) :: text_pos, text_size

    checkbox_height_px = boundary%height*checkbox_height_rl
    checkbox_padding_px = boundary%height*checkbox_padding_rl

    cross_boundary%width = boundary%width*checkbox_width_rl
    cross_boundary%height = checkbox_height_px
    cross_boundary%x = boundary%x + boundary%width/2 - cross_boundary%width/2
    cross_boundary%y = boundary%y + boundary%height/2 - checkbox_height_px - checkbox_padding_px*0.5

    knott_boundary%width = boundary%width*checkbox_width_rl
    knott_boundary%height = checkbox_height_px
    knott_boundary%x = boundary%x + boundary%width/2 - knott_boundary%width/2
    knott_boundary%y = boundary%y + boundary%height/2 + checkbox_padding_px*0.5

    text_size = measure_text_ex(game_font, "AI"//C_NULL_CHAR, checkbox_height_px, 0.0)
    text_pos = Vector2( &
         [cross_boundary%x, &
         ! cross_boundary%x + cross_boundary%width/2 - text_size%x/2, &
         cross_boundary%y - checkbox_height_px - checkbox_padding_px])
    call draw_text_ex(game_font, "AI"//C_NULL_CHAR, text_pos,checkbox_height_px, 0.0, restart_button_color)

    call checkbox(cross_checkbox_id,CELL_CROSS,cross_boundary,ai_checkboxes(CELL_CROSS))
    call checkbox(knott_checkbox_id,CELL_KNOTT,knott_boundary,ai_checkboxes(CELL_KNOTT))
  end subroutine render_ai_checkboxes

  subroutine render_tie_state()
    call render_board(board_x_px, board_y_px, board_size_px, board)
    call render_particles(dt)

    if (restart_button(game_font, board_x_px, board_y_px, board_size_px)) then
      call restart_game()
    end if
  end subroutine render_tie_state

  subroutine render_won_state()
    call render_board(board_x_px, board_y_px, board_size_px, board)
    call render_particles(dt)

    call strikethrough(final_line, Square([board_x_px, board_y_px], board_size_px))
    if (restart_button(game_font, board_x_px, board_y_px, board_size_px)) then
       call restart_game()
    end if
  end subroutine render_won_state

  subroutine render_game_state()
    integer           :: x_cl, y_cl
    real              :: board_cell_size
    real,dimension(2) :: start, end

    board_cell_size = board_size_px/board_size_cl

    if (ai_checkboxes(current_player)) then
       call render_board(board_x_px, board_y_px, board_size_px, board)

       if (.not. ai_next_move(board, current_player, x_cl, y_cl)) then
          board(x_cl, y_cl) = current_player
          if (.not. click_played_on_previous_frame) then
             call play_sound(click_sound)
             click_played_on_this_frame = .true.
          end if
          if (player_won(board, CELL_CROSS, [x_cl, y_cl], final_line)) then
             state = STATE_WON
             call map_tline_on_screen(final_line, Square([board_x_px, board_y_px], board_size_px), start, end)
             call spawn_random_particles_along_line(start, end, particles_burst_count*3, strikethrough_color)
             return
          end if
          if (player_won(board, CELL_KNOTT, [x_cl, y_cl], final_line)) then
             state = STATE_WON
             call map_tline_on_screen(final_line, Square([board_x_px, board_y_px], board_size_px), start, end)
             call spawn_random_particles_along_line(start, end, particles_burst_count*3, strikethrough_color)
             return
          end if
          call spawn_random_particles_in_region( &
               Rectangle(board_x_px + (x_cl - 1)*board_cell_size,   &
                         board_y_px + (y_cl - 1)*board_cell_size,   &
                         board_cell_size,        &
                         board_cell_size),       &
               particles_burst_count,                               &
               shape_colors(current_player))
          current_player = 3 - current_player
          if (board_full(board)) then
             state = STATE_TIE
             return
          end if
       else
          state = STATE_TIE
          return
       end if
    else
       if (render_board_clickable(board_x_px, board_y_px, board_size_px, board, x_cl, y_cl)) then
          board(x_cl, y_cl) = current_player
          if (.not. click_played_on_previous_frame) then
             call play_sound(click_sound)
             click_played_on_this_frame = .true.
          end if
          if (player_won(board, CELL_CROSS, [x_cl, y_cl], final_line)) then
             state = STATE_WON
             call map_tline_on_screen(final_line, Square([board_x_px, board_y_px], board_size_px), start, end)
             call spawn_random_particles_along_line(start, end, particles_burst_count*3, strikethrough_color)
             return
          end if
          if (player_won(board, CELL_KNOTT, [x_cl, y_cl], final_line)) then
             state = STATE_WON
             call map_tline_on_screen(final_line, Square([board_x_px, board_y_px], board_size_px), start, end)
             call spawn_random_particles_along_line(start, end, particles_burst_count*3, strikethrough_color)
             return
          end if
          call spawn_random_particles_in_region( &
               Rectangle(board_x_px + (x_cl - 1)*board_cell_size,   &
                         board_y_px + (y_cl - 1)*board_cell_size,   &
                         board_cell_size,        &
                         board_cell_size),       &
               particles_burst_count,                       &
               shape_colors(current_player))
          current_player = 3 - current_player
          if (board_full(board)) then
             state = STATE_TIE
             return
          end if
       end if
    end if
    call render_particles(dt)
  end subroutine render_game_state

  subroutine restart_game()
    board(:,:) = 0
    state = STATE_GAME
    current_player = CELL_CROSS
  end subroutine restart_game
end program

! # Roadmap
! - TODO: customizable board size
! - TODO: sound volume controls
! - TODO: accessibility: control via keyboard