fortran/app/sokoban.f90 · 11601 字节 · 下载原文

! 推箱子 —— 用 **Fortran** 写的手机游戏

! Sokoban -- a mobile game written in **Fortran**

!

! 玩法：方向键推箱子，把两个箱子都推到目标点上即过关（回车重开、ESC 退出）。

! Gameplay: push the boxes with the arrow keys; get both boxes onto the target cells to win (Enter restarts, ESC exits).

! 箱子只能推、不能拉；推到墙或另一个箱子上就推不动。

! Boxes can only be pushed, never pulled; pushing into a wall or another box does not move them.

!

! 与前面几份刻意不同：这份是**双数组状态 + 移动规则 + 过关判定**，

! Deliberately different from the earlier files: this one is **two-array state + movement rules + win detection**,

! 一帧里没有任何连续位移 —— 照的是「离散格子 + 规则表」这条路径。

! with no continuous motion within a frame -- it exercises the "discrete cells + rule table" path.

! 也刻意不画数字：`ui_2d_text` 要字符串，而 Fortran 没有现成的数字转字符串路径，

! It also deliberately draws no digits: `ui_2d_text` needs a string, and Fortran has no ready-made number-to-string path,

! 所以状态一律用**颜色与形状**表达（目标=空心框、箱子=实心方块、箱子归位=变绿）。

! so state is expressed purely with **color and shape** (target = hollow frame, box = solid square, box in place = turns green).

!

! ◆ 手机那套 UI

! ◆ The mobile UI set

!

! 开窗 / 绘图 / 输入 / 定时器是 C 写的（`Lib/shared/src/vmlui.c` → `vmlui.vml`），

! Window opening / drawing / input / timers are written in C (`Lib/shared/src/vmlui.c` -> `vmlui.vml`),

! 由 `vmltool.config.xml` 的 `<Language Name="fortran" Libs="vmlui.vml">` 挂上来。

! pulled in by `<Language Name="fortran" Libs="vmlui.vml">` in `vmltool.config.xml`.

!

! ◆ 写法要求（沿用 corpus/fortran/skel.f90 的两条）

! ◆ Style requirements (the two from corpus/fortran/skel.f90)

!

!   · `call ui_2d_rect(...)` 会被编成 `CALL sub_ui_rect`，而链接器只剥

!   · `call ui_2d_rect(...)` compiles to `CALL sub_ui_rect`, and the linker strips only

!     func_/word_/method_/var_ 四种前缀、**不含 sub_** ⇒ 碰不到 UI 库。

!     the four prefixes func_/word_/method_/var_, **not sub_** => it never reaches the UI library.

!     所以一律写成**函数调用表达式** `k = ui_2d_rect(...)`（编成 func_ui_rect）。

!     So always write a **function-call expression** `k = ui_2d_rect(...)` (compiles to func_ui_rect).

!   · Fortran 数组 **1 基**：扁平下标 = (行-1)*8 + 列 + 1。

!   · Fortran arrays are **1-based**: flat index = (row-1)*8 + column + 1.


program sokoban
  implicit none
  integer :: map(64)     ! 0=地板 1=墙 2=目标点

  ! 0=floor 1=wall 2=target cell

  integer :: obj(64)     ! 0=空 1=箱子 2=玩家

  ! 0=empty 1=box 2=player

  integer :: i
  integer :: k
  integer :: w
  integer :: h
  integer :: cell
  integer :: ox
  integer :: oy
  integer :: pr
  integer :: pc
  integer :: done
  integer :: t
  integer :: key
  integer :: tid
  integer :: nr
  integer :: nc
  integer :: ni
  integer :: over
  integer :: goals
  integer :: lang

  ! 界面语言：开局问一次宿主要中文还是英文（0=中文 1=英文），之后整局按它分支。

  ! UI language: ask the host once at start whether Chinese or English (0=Chinese 1=English), then branch on it for the whole round.

  ! ⚠ 别在每帧里调 —— 那是一次 syscall。

  ! ⚠ Do not call it every frame -- that is a syscall.

  ! ⚠ 本前端**没有三元/merge**，界面文字只能靠单行 `if` 二选一

  ! ⚠ This frontend has **no ternary/merge**, so UI text can only pick between two options with a single-line `if`

  !   （sokoban 本来就在用这个写法，见下面的 `if (key == 37) nc = pc - 1`）。

  !   (sokoban already used this style, see `if (key == 37) nc = pc - 1` below).

  lang = ui_scr_get_language()

  if (lang == 0) k = ui_win_open('推箱子', 0, 0)
  if (lang /= 0) k = ui_win_open('Sokoban', 0, 0)

  w = ui_scr_get_w()
  h = ui_scr_get_h()
  if (w <= 0) then
    w = 360
  end if
  if (h <= 0) then
    h = 620
  end if

  cell = (w - 40) / 8
  ! ⚠ 本前端在 `if` 条件里解析不了「紧跟括号的除法」（`Unexpected token: Div(/)`）⇒ 先算进变量

  ! ⚠ This frontend cannot parse "a division right after a parenthesis" in an `if` condition (`Unexpected token: Div(/)`) => compute it into a variable first

  k = (h - 150) / 8
  if (k < cell) then
    cell = k
  end if
  if (cell < 8) then
    cell = 8
  end if
  ox = (w - cell * 8) / 2
  oy = 90

  ! ── 关卡：边框是墙，两个目标点、两个箱子 ──

  ! -- Level: the border is walls, with two targets and two boxes --

  ! 地图用代码建（不用 64 个字面量），内部障碍摆两块

  ! The map is built in code (not with 64 literals), with two internal obstacles placed in it

  do i = 1, 64
    map(i) = 0
    obj(i) = 0
  end do

  ! 边框：第 1/8 行、第 1/8 列

  ! Border: rows 1/8, columns 1/8

  do i = 1, 8
    map(i) = 1                 ! 顶行

    ! top row

    map(56 + i) = 1            ! 底行

    ! bottom row

    map((i - 1) * 8 + 1) = 1   ! 左列

    ! left column

    map((i - 1) * 8 + 8) = 1   ! 右列

    ! right column

  end do
  ! 两块内部障碍

  ! Two internal obstacles

  map(3 * 8 + 4 + 1) = 1
  map(5 * 8 + 4 + 1) = 1

  ! 目标点：(行,列) = (3,3) 与 (5,6)

  ! Targets: (row,column) = (3,3) and (5,6)

  map((3 - 1) * 8 + 3 + 1) = 2
  map((5 - 1) * 8 + 6 + 1) = 2
  ! 箱子：(2,2) 与 (3,6)

  ! Boxes: (2,2) and (3,6)

  obj((2 - 1) * 8 + 2 + 1) = 1
  obj((3 - 1) * 8 + 6 + 1) = 1
  ! 玩家：(5,3)

  ! Player: (5,3)

  pr = 5
  pc = 3
  obj((pr - 1) * 8 + pc + 1) = 2

  k = ui_scr_set_keep_on(1)
  done = 0
  tid = ui_timer_set(120, 0)

  do while (ui_win_is_closed() == 0)

    ui_sfx_tick()
    ! ── 过关判定：目标点上都有箱子 ──

    ! -- Win detection: every target cell has a box --

    goals = 0
    do i = 1, 64
      if (map(i) == 2) then
        if (obj(i) == 1) then
          goals = goals + 1
        end if
      end if
    end do
    if (goals == 2) then
      done = 1
    end if

    ! ── draw ──

    k = ui_2d_clear(-15723504)
    ! 用显式两层循环画（比一维反解行号清楚）

    ! Draw with an explicit two-level loop (clearer than reverse-solving row numbers from a flat index)

    do nr = 1, 8
      do nc = 1, 8
        ni = (nr - 1) * 8 + nc
        if (map(ni) == 1) then
          k = ui_2d_rect(ox + (nc - 1) * cell, oy + (nr - 1) * cell, cell, cell, -11841664, 1, 0, 0)
        else
          k = ui_2d_rect(ox + (nc - 1) * cell, oy + (nr - 1) * cell, cell, cell, -15719856, 1, 0, 1)
        end if
        if (map(ni) == 2) then
          k = ui_2d_rect(ox + (nc - 1) * cell + cell / 4, oy + (nr - 1) * cell + cell / 4, cell / 2, cell / 2, -11513776, 0, 3, 0)
        end if
        if (obj(ni) == 1) then
          if (map(ni) == 2) then
            k = ui_2d_rect(ox + (nc - 1) * cell + 3, oy + (nr - 1) * cell + 3, cell - 6, cell - 6, -131246, 1, 0, 2)
          else
            k = ui_2d_rect(ox + (nc - 1) * cell + 3, oy + (nr - 1) * cell + 3, cell - 6, cell - 6, -11409298, 1, 0, 2)
          end if
        end if
        if (obj(ni) == 2) then
          k = ui_2d_circle(ox + (nc - 1) * cell + cell / 2, oy + (nr - 1) * cell + cell / 2, cell / 2 - 6, -63488, 1, 0)
        end if
      end do
    end do

    if (done == 0) then
      if (lang == 0) k = ui_2d_text(8, 8, '推箱子：把两个箱子推到空心格', -6643536, 13, 0)
      if (lang /= 0) k = ui_2d_text(8, 8, 'Push boxes onto the hollow targets', -6643536, 13, 0)
    else
      if (lang == 0) k = ui_2d_text(8, 8, '过关！回车再来一次', -131246, 16, 0)
      if (lang /= 0) k = ui_2d_text(8, 8, 'Cleared! Press Enter to restart', -131246, 16, 0)
    end if
    k = ui_2d_present()

    t = ui_msg_fetch_wait(0)
    if (t == 10) then
      exit
    end if

    if (t == 1) then
      key = ui_msg_get_a()
      if (key == 27) then
        exit
      end if
      if (key == 13) then
        ! 重开：把箱子与玩家放回原位

        ! Restart: put the boxes and the player back in their original places

        obj((2 - 1) * 8 + 2 + 1) = 1
        obj((3 - 1) * 8 + 6 + 1) = 1
        obj((pr - 1) * 8 + pc + 1) = 0
        pr = 5
        pc = 3
        obj((pr - 1) * 8 + pc + 1) = 2
        done = 0
      end if

      ! 方向键 → 目标格

      ! Arrow key -> target cell

      nr = pr
      nc = pc
      if (key == 37) nc = pc - 1
      if (key == 39) nc = pc + 1
      if (key == 38) nr = pr - 1
      if (key == 40) nr = pr + 1
      if (nr /= pr .or. nc /= pc) then
        ni = (nr - 1) * 8 + nc
        if (map(ni) /= 1) then
          if (obj(ni) == 0) then
            ! 空地：走过去

            ! Empty floor: step onto it

            obj((pr - 1) * 8 + pc + 1) = 0
            pr = nr
            pc = nc
            obj((pr - 1) * 8 + pc + 1) = 2
          else
            if (obj(ni) == 1) then
              ! 箱子：看它后面那格能不能放

              ! A box: check whether the cell behind it is free

              over = (nr - pr) + (nc - pc)
              if (over == -1) then
                if (map((nr - 1) * 8 + nc - 1) == 1) over = 0
                if (obj((nr - 1) * 8 + nc - 1) /= 0) over = 0
                if (over /= 0) then
                  obj((nr - 1) * 8 + nc - 1) = 1
                end if
              end if
              if (over == 1) then
                if (map((nr - 1) * 8 + nc + 1) == 1) over = 0
                if (obj((nr - 1) * 8 + nc + 1) /= 0) over = 0
                if (over /= 0) then
                  obj((nr - 1) * 8 + nc + 1) = 1
                end if
              end if
              if (over == -8) then
                if (map((nr - 2) * 8 + nc) == 1) over = 0
                if (obj((nr - 2) * 8 + nc) /= 0) over = 0
                if (over /= 0) then
                  obj((nr - 2) * 8 + nc) = 1
                end if
              end if
              if (over == 8) then
                if (map(nr * 8 + nc) == 1) over = 0
                if (obj(nr * 8 + nc) /= 0) over = 0
                if (over /= 0) then
                  obj(nr * 8 + nc) = 1
                end if
              end if
              ! 推得动才走

              ! Only move if it can be pushed

              if (over /= 0) then
                obj(ni) = 0
                obj((pr - 1) * 8 + pc + 1) = 0
                pr = nr
                pc = nc
                obj((pr - 1) * 8 + pc + 1) = 2
                call ui_sfx_add(0, 84, 0, 2, 75, 1)      ! 推到位：上行两音

                ! Pushed into place: two rising notes

                call ui_sfx_add(1, 91, 1, 4, 70, 1)
              else
                call ui_sfx_add(2, 48, 0, 2, 80, 2)   ! 推不动：低闷

                ! Cannot push: low and muffled

              end if
            end if
          end if
        else
          call ui_sfx_add(2, 48, 0, 2, 80, 2)   ! 推不动：低闷

          ! Cannot push: low and muffled

        end if
      end if
    end if
  end do

  k = ui_timer_kill(tid)
  k = ui_scr_set_keep_on(0)
  k = ui_win_close()
end program sokoban