From f66176df6f9fdb01ead92663e21084c8bc28816b Mon Sep 17 00:00:00 2001 From: Claude Date: Wed, 4 Nov 2026 20:26:30 +0000 Subject: [PATCH] graal-5.00r7-G3D22067: 0.0.1 rebuild of the 5.00r7 client Copied from the 3.153 rebuild and changed where the 5.x notes in graal_analysis say 5.00r7 differs: token G3D22067; the login line ends with win and three empty machine fields and goes alone in the login frame, with 37 in its own gen-5 frame; no listserver step, the first server is Login and no characters are drawn there until a server warp (178, split on commas only); 100 server ids; first props nickname, colours, language, win and X2/Y2; movement as X2/Y2 every tick; 182 answered with 44. The start screen still gets its list from a Seihai listserver, and a picked server plays at once under its own name. Co-Authored-By: Claude Opus 5.5 Claude-Session: https://claude.ai/code/session_01UG2Sqj7kV7T5jY5LoeZRuJ --- graal-5.00r7-G3D22067/README.md | 97 + graal-5.00r7-G3D22067/RELEASE_NOTES.md | 62 + graal-5.00r7-G3D22067/src/Adventure.pas | 2073 ++++++++++++++++++ graal-5.00r7-G3D22067/src/Graal500.dpr | 604 +++++ graal-5.00r7-G3D22067/src/GraalClient.pas | 508 +++++ graal-5.00r7-G3D22067/src/ListServer500.pas | 96 + graal-5.00r7-G3D22067/src/Protocol500.pas | 316 +++ graal-5.00r7-G3D22067/src/RunMode.pas | 338 +++ graal-5.00r7-G3D22067/src/StartScreen500.pas | 113 + graal-5.00r7-G3D22067/tests/Capture500.inc | 97 + graal-5.00r7-G3D22067/tests/Test500.dpr | 1222 +++++++++++ 11 files changed, 5526 insertions(+) create mode 100644 graal-5.00r7-G3D22067/README.md create mode 100644 graal-5.00r7-G3D22067/RELEASE_NOTES.md create mode 100644 graal-5.00r7-G3D22067/src/Adventure.pas create mode 100644 graal-5.00r7-G3D22067/src/Graal500.dpr create mode 100644 graal-5.00r7-G3D22067/src/GraalClient.pas create mode 100644 graal-5.00r7-G3D22067/src/ListServer500.pas create mode 100644 graal-5.00r7-G3D22067/src/Protocol500.pas create mode 100644 graal-5.00r7-G3D22067/src/RunMode.pas create mode 100644 graal-5.00r7-G3D22067/src/StartScreen500.pas create mode 100644 graal-5.00r7-G3D22067/tests/Capture500.inc create mode 100644 graal-5.00r7-G3D22067/tests/Test500.dpr diff --git a/graal-5.00r7-G3D22067/README.md b/graal-5.00r7-G3D22067/README.md new file mode 100644 index 0000000..fa6a1ff --- /dev/null +++ b/graal-5.00r7-G3D22067/README.md @@ -0,0 +1,97 @@ +# Graal 5.00 rev 7 (`G3D22067`) + +The 5.00r7 client, rebuilt. The original is the Windows build of July +2007: a Delphi launcher over a C++ engine library. On the wire it keeps the +gen-5 codec of 2.22 to 4.20, with its own token, no tamper check and no +listserver. This folder starts from `graal-3.153-G3D28015` and changes what +the 5.x notes say differs. This is the 0.0.1 reproduction: hit or miss. + +> **Not affiliated.** graal-delphi is an independent fan project. It is not +> affiliated with, endorsed by, or connected to GraalOnline or +> graalonline.com, Cyberjoueurs, or Stéphane Portha ("unixmad"). + +## Sources + +From [graal_analysis](https://github.com/squirelworks/graal_analysis), not +from decompiled code: + +| Area | Notes | +|---|---| +| Token, login line, ids handled, Login server | `protocol/v5x-clients.md` | +| Ids, props, login fields in table form | `version-profiles/5.00-6.03.toml` | +| Login mode, server warp, movement, timings | `version-profiles/lab-v5-2026-10-30.md` | +| What the server sends and the client answers | `protocol/v5v6-lab-play.md` | +| Everything carried over | `../graal-3.153-G3D28015/README.md`, `../graal-2.22-GNW03014/README.md` | + +## What differs from the 3.153 rebuild + +| | 3.153 | 5.00r7 (this folder) | +|---|---|---| +| Game token | `G3D28015` | `G3D22067` | +| Login line | ends at the password | then `win,"","",""` (platform and three machine fields) | +| First frame | 5, 37, 34 bigmap, 34 minimap | 5 alone; 37 in its own gen-5 frame | +| Listserver | `G3D30123newmain` | none: the first server is a game server named `Login` | +| Login mode | no | while the server's name starts with "login", no characters are drawn | +| Server warp (178) | comma text | split on commas only; the name becomes the server's name | +| Server ids handled | 88 | 100: adds 105-107, 140, 170, 182, 183, 190, 191, 193-195, 197 | +| First props | 0, 18, 31, 33, 52, 75 `mac`, 76 | 0, 13, 52, 75 `win`, then X2 and Y2 | +| Movement | X and Y every other tick | X2 / Y2 (78, 79), pixels, every tick, only what changed | +| Process list (182) | not handled | answered with 44 | + +The machine fields are MD5 hashes of the Windows product id, the adapter +MAC and the `C:` volume serial on the original. The rebuild reads none of +them and sends each as `""`, which is what the real 5.00r7 sent for its MAC +field in the lab. Its answer to 182 names only its own game window (the +server's name), not the processes on the machine. + +## Units + +As in 3.153, with the suffix `500`: `Protocol500`, `GraalClient`, +`Adventure`, `Graal500.dpr`, `ListServer500`, `StartScreen500`, `RunMode`. + +## Running it + +Put `Graal500` in the root of a 5.00r7 install and start it with no +arguments for the start screen. It finds the install's files from there, +or from `graal-assets/5.00r7/` and `graal-assets/common/` next to it. + +Start asks a Seihai listserver for the server list (`listserver.txt` next +to the program, else `listserver.graal.in` on 14922), since the rebuild +cannot show the Login server's scripted list. The picked server's name +becomes the client's server name, as if the Login server had already +warped there, so the player is drawn. + +``` +GRAAL_PW=... Graal500 --server HOST:PORT --account NAME # as Login +GRAAL_PW=... Graal500 --server HOST:PORT --account NAME --server-name Classic +Graal500 --level some.nw # offline +``` + +With `--server` and no `--server-name` the server is `Login`: the level is +drawn, characters are not, until the server sends a 178. + +## Files it opens + +From the program's folder (or `--data`), then `graal-assets/5.00r7/`, then +`graal-assets/common/`: + +- `pics1.png` (or `pics1.gif`), `arrays.dat` +- `levels/` for levels, ganis and images; `levels/heads/`, `levels/bodies/`, + `levels/swords/`, `levels/shields/`, `levels/hats/`, `levels/images/` +- `levels/offlinetutorial_b-2.nw` (or `.graal`) for Training, else `start.nw` +- `listserver.txt` (optional) + +## Not yet, or not known + +- The Login server's scripted GUI (server list, accounts) and GS2 in + general: 140 and 197 (class and weapon scripts, the `GRESCR01` cache), + 195 (gani scripts) and 190 (`onServerListerConnect`) are accepted and + ignored. +- `GR-V1.05` levels (tile layers) and `GRPKG001` update packages. +- The base-file requests after the language (`basepackage.gupd` by 47 or 23). +- The keep-alive 24 the lab saw every 5 s: its payload was not recorded. +- 183 ("is this process running?") is accepted and not answered. +- Whether 5.00r7 plays offline at all is not traced; Training keeps 3.153's. +- The 3D mode (Torque, `Graal3DEngine.dll`, protocol 24). +- No side-by-side run against the real 5.00r7; that is 0.0.2 work. +- Everything still missing from the 3.153 rebuild. diff --git a/graal-5.00r7-G3D22067/RELEASE_NOTES.md b/graal-5.00r7-G3D22067/RELEASE_NOTES.md new file mode 100644 index 0000000..b0de442 --- /dev/null +++ b/graal-5.00r7-G3D22067/RELEASE_NOTES.md @@ -0,0 +1,62 @@ +# Graal 5.00 rev 7 (G3D22067) + +The first rebuild of the Graal 5.00 rev 7 client, in Delphi (Object +Pascal). The original is a Windows program from 2007; this rebuild runs on +Linux and Windows. It is an early version: most of the game (NPCs, items, +weapons, scripts, the scripted login screens, the 3D mode) is not there +yet. + +> **Not affiliated.** graal-delphi is an independent fan project. It is not +> affiliated with, endorsed by, or connected to GraalOnline or +> graalonline.com, Cyberjoueurs, or Stéphane Portha ("unixmad"). + +These zips hold no original Graal code, graphics, sounds or levels. The +program carries small original default graphics and a starter level of its +own, so it runs as it is. Put it in the root of a 5.00r7 install you own +(or point it at one with `--data DIR`) and the install's tiles, ganis, +heads and bodies take their place. The shared `graal-assets/` folder next +to the program works too (`graal-assets/5.00r7/`, then +`graal-assets/common/`). + +## Downloads + +| Zip | Runs on | Window | +|---|---|---| +| `…-linux.zip` | Linux x86-64 | X11 | +| `…-windows.zip` | Windows, 32-bit | GDI | + +Each zip has `Graal500` (the client), `Test500` (its test suite) and the +build's README. + +## What works + +- The start screen: nick name, Training, Start. Start fetches the server + list from `listserver.txt` next to the program, or else + `listserver.graal.in` on port 14922. Then account, password and Connect. +- Login with `G3D22067`, the platform `win` and three empty machine + fields; the language in its own frame; no tamper check. +- The Login server: a server reached by its address alone is called + Login, and there the level is drawn but no characters, until the server + moves the client on with a server warp. A server picked from the list + plays at once. +- Server warps: the client logs in again to the named host and port, under + the new name. +- The first props with `win` as the system name; movement sent every tick + in whole pixels. +- The board, the player and other players drawn from the install's tiles + and ganis; walking and collision; level links; gmaps and their edges. +- A headless mode for stress runs, with JSON stats. + +## Not yet + +NPCs, baddies, items and weapons; scripts (class, weapon and gani scripts +and their cache); the scripted server list and account screens; chat; +layered levels; update packages; the 3D mode. See the build's README for +the full list. + +## Checks behind this release + +The test suite (94 checks) runs with range and overflow checks and the heap +tracer, and must end with no unfreed memory. CI also logs two of these +clients into seihai-gserver, has the second see the first, and walks one +through a level link. diff --git a/graal-5.00r7-G3D22067/src/Adventure.pas b/graal-5.00r7-G3D22067/src/Adventure.pas new file mode 100644 index 0000000..ada66a8 --- /dev/null +++ b/graal-5.00r7-G3D22067/src/Adventure.pas @@ -0,0 +1,2073 @@ +{ Adventure: TAdventure, the game state and frame loop of 5.00r7, carried + over from the 3.153 rebuild (itself from 2.22), since 5.00r7 keeps the + gen-5 wire (graal_analysis protocol/v5x-clients.md, + version-profiles/5.00-6.03.toml). What 5.00r7 does differently + (version-profiles/lab-v5-2026-10-30.md, protocol/v5v6-lab-play.md): the + first server is named Login, and while the server's name starts with + "login" no characters are drawn; a server warp (178) moves it to the + server it names, split on commas only; first props nickname, colours, + language, OSTYPE win and the position; movement goes out as X2 / Y2 + (78, 79) every tick, only the coordinate that changed; and it answers + the process-list request (182) with 44. No tamper check anywhere. + The notes below are the 2.22 ones they came from. + + As in 2.05, TAdventure owns the level, the local player, the link to the + server and the frame function that runs on a 50 ms gate. 2.22 adds gmaps + (a grid of levels played as one world), a level cache that lets it ask + for a level by mod time (PLI_LEVELWARPMOD), and the 2.1+ player props + (GANI as a string, OSTYPE, TEXTCODEPAGE, GMAPLEVELX/Y). + + Sources: graal_analysis protocol/player-props.md (2.22 parser sets), + client-internals/feature-specs/06-gmap-overworld.md (gmap login and edge + crossings captured from a real 2.22), decomp-findings-2026-10-24-b/ + 08-lab-findings-levelchange-24-178.md (39 after each client warp, 24, + 178), the b4_222 capture (first client frame, walk props) and run-222d + (movement, turns, the link probe). } +unit Adventure; + +{$IFDEF FPC}{$MODE DELPHI}{$H+}{$ENDIF} + +interface + +uses + Classes, GTypes, GLevel, GSurface, GArrays, GAni, GBuiltin, GAssetDirs, GraalClient, Protocol500; + +const + { The game view. 640x480 is assumed for 2.22 as for 2.05; not read from + the binary. } + ScreenW = 640; + ScreenH = 480; + + { Directions, as the walking routine numbers them. } + DirUp = 0; + DirLeft = 1; + DirDown = 2; + DirRight = 3; + + { The colour list (client-internals/body-colours-and-attributes.md). } + ColorTable: array[0..19] of Cardinal = ( + $FFFFFFFF, $FFFFFF00, $FFFFAD6B, $FFFF8484, $FFFF0000, $FFCE1829, + $FF84FF84, $FF00FF00, $FF00C600, $FF8484FF, $FF0000FF, $FF0000C6, + $FF840000, $FF00FFFF, $FFFF00FF, $FF840084, $FFCECECE, $FF848484, + $FF000008, $00000000); + + +type + { Images and ganis from the player's install, loaded once and kept. } + TAssets = class + private + FNames: TStringList; { lower-case key -> TGSurface or TGraalAni } + function FindFile(const Name: string; const Dirs: array of string): string; + public + Dir: string; { install folder; '' = none } + Missing: TStringList; { names looked for and not found, once each } + constructor Create; + destructor Destroy; override; + { Nil when not found. Kind picks the sub-folders searched. } + function Image(const Name, Kind: string): TGSurface; + function Ani(const Name: string): TGraalAni; + { A file in the install (levels/ first), or ''. } + function LevelFile(const Name: string): string; + end; + + { A level as the client keeps it for the session: the board, links and + signs as last sent, and the mod time the server gave it. } + TCachedLevel = class(TAdventureLevel) + public + ModTime: Cardinal; + HasModTime: Boolean; + HasBoard: Boolean; + end; + + { A GRMAP001 file: a grid of level names played as one world + (formats/gmap.md). } + TGmap = class + public + Name: string; + Width, Height: Integer; + Cells: TStringList; { row-major level names, '' for an empty cell } + constructor Create; + destructor Destroy; override; + function LoadFromString(const Data: string): Boolean; + { The level of a cell, or '' outside the grid or for an empty cell. } + function CellName(CX, CY: Integer): string; + { The cell of a level name; False when it is not on this map. } + function FindCell(const Level: string; out CX, CY: Integer): Boolean; + end; + + TServerPlayer = class + public + Id: Integer; + Nickname, Account, Level, HeadImage, BodyImage, SwordImage, ShieldImage, + Chat, Language, OsType: string; + Attr: array[1..5] of string; + X, Y: Double; { tiles, top-left of the 3x3-tile sprite box } + Z, GmapX, GmapY: Integer; + Sprite, Status, MaxPower, Power, Rupees, Arrows, Bombs: Integer; + SwordPower, ShieldPower, GlovePower, BombPower, CodePage: Integer; + Colors: array[0..4] of Integer; + Dir: Integer; + AniName: string; + AniStart: Integer; { frame the animation started on } + { -1: the animation runs with time. Otherwise the step to draw (a + player whose server sends only the old sprite prop). } + FixedStep: Integer; + HasGani: Boolean; { a GANI prop was seen: the pose comes from it } + Gone: Boolean; { PCONNECTED or a level leave seen } + BodyCache: TGSurface; { the body recoloured for this player } + BodyKey: string; + constructor Create; + destructor Destroy; override; + { Parses a prop stream. Stops at the first id the stream does not + accept, the way 2.22 does, and returns the ids applied. Other is the + OTHERPLPROPS stream. Frame is the tick, for a new animation. } + function ApplyProps(R: TGReader; Other: Boolean; Frame: Integer): string; + { The pose from an old-style sprite prop (no GANI from the server). } + procedure PoseFromSprite; + procedure SetAni(const Name: string; Frame: Integer); + end; + + TAdventure = class + private + FClient: TAdventureClient; + FLog: TStrings; + FSentX, FSentY: Double; + FSentDir, FSentGmapX, FSentGmapY: Integer; + FSentGani: string; + FPropsSent: Boolean; + FOthers: TList; + { addtiledef lines seen in level scripts: 'prefix'#9'image', newest + first; FTileDefLevel is the level last scanned } + FTileDefs: TStringList; + FTileDefLevel: string; + FLevels: TStringList; { lower-case name -> TCachedLevel } + FLevelDir: string; { folder of the level file played offline } + FWarpPending: Boolean; { a link warp was asked of the server } + FWarpX, FWarpY: Double; + FWarpLevel: string; + FWarpTimed: string; { the level a timed warp waits for } + FWarpT0: Int64; + FAdjacentAsked: TStringList; + FGmapWanted: string; { a .gmap asked for with WANTFILE } + FAccount, FPassword, FHost: string; + FPort: Word; + { the level that LEVELNAME named last: the data after it is its own + (a gmap neighbour's data goes to that neighbour, not the player's) } + FCurrentData: TCachedLevel; + procedure WarpDone; + procedure HandleMessage(Id: Integer; const Data: string); + procedure ClientLog(const Line: string); + function PointBlocked(PX, PY: Double): Boolean; + procedure SendLoginFrame; + procedure SendMovedProps; + function BodyFor(P: TServerPlayer): TGSurface; + function GetOther(I: Integer): TServerPlayer; + function GetOtherCount: Integer; + function GetCurrent: TCachedLevel; + procedure SetGmap(const Name: string); + procedure AskAdjacent; + procedure CrossEdges; + procedure ReceiveFile(const Data: string); + procedure ServerWarp(const Data: string); + procedure ListProcesses; + public + { The current server's name: FirstServerName for an address given + straight, the list entry's name for a server picked from a list, the + name a server warp (178) gives. } + ServerName: string; + Level: TCachedLevel; { the level the player is in } + Gmap: TGmap; { the active gmap, nil off a gmap or before it loads } + GmapName: string; { the active gmap's name, '' off a gmap } + Player: TServerPlayer; + Screen: TGSurface; + Sheet: TGSurface; { pics1 } + SheetBuiltin: Boolean; { Sheet is the built-in default } + Arrays: TGArrays; + Assets: TAssets; + Frame: Integer; + WorldTime: Cardinal; + ServerMessage, DisconnectReason: string; + LoggedIn, BoardLoaded: Boolean; + Frozen: Boolean; + { No drawing in the tick: for stress runs. } + Headless: Boolean; + { Log lines also go to stderr as they happen. The in-memory log keeps + the last LogKeep lines either way. } + Echo: Boolean; + { Timings, in ms: connect to the first board (-1 until then), and + each link warp from the request to the new board. } + ConnectAtMs: Int64; + LoginMs: Integer; + WarpsSent: Integer; + WarpTimes: array of Integer; { the first WarpCount entries are used } + WarpCount: Integer; + EdgeCrossings: Integer; + ServerWarps: Integer; + Handled, Ignored: array[0..255] of Integer; + { Held direction keys for this tick: up, left, down, right. } + Keys: array[0..3] of Boolean; + { The clock the tick reads, in ms; tests set it. } + ClockMs: Int64; + UseWallClock: Boolean; + constructor Create; + destructor Destroy; override; + { True while ServerName starts with "login" (any case): Login mode, + where 5.00r7 draws the level and chests but no characters. } + function LoginMode: Boolean; + procedure Log(const S: string); + { Points pics1, arrays.dat and the image folders at an install. } + procedure UseInstall(const Dir: string); + { Draws P with the camera at (CamX, CamY) pixels; also used for the + character on the start screen. } + procedure DrawPlayer(P: TServerPlayer; CamX, CamY: Integer); + { The built-in tile sheet and tile types (done by Create). } + procedure UseBuiltins; + { Notes the addtiledef lines in L's NPC scripts. } + procedure NoteTileDefs(L: TAdventureLevel); + { The tile sheet for a level: an addtiledef image whose prefix starts + the level name, else pics1. } + function TileSheetFor(const LevelName: string): TGSurface; + property TileDefs: TStringList read FTileDefs; + function ConnectServer(const Host: string; Port: Word; + const Account, Password: string): Boolean; + { The walking routine for one direction key (one step). } + procedure WalkStep(Dir: Integer); + { One frame: network in, game step, network out, draw. } + procedure Tick; + procedure Draw; + { Loads a level (or a .gmap and its levels) from disk for offline play; + links then look for their levels next to it, then in the install. } + function LoadLevelFile(const FileName: string): Boolean; + { The cached level of that name; Make adds an empty one. } + function CachedLevel(const Name: string; Make: Boolean): TCachedLevel; + { The tile at a position in the current gmap's world (or the level when + not on a gmap), -1 where no board is known. } + function WorldTile(GX, GY: Integer): Integer; + { The link under the player, or -1. } + function LinkAt(PX, PY: Double): Integer; + { Takes link I: online, asks the server for the level; offline, loads + it. Returns False when the level cannot be had. } + function FollowLink(I: Integer): Boolean; + { One message from the server, as the client's dispatcher hands it on. } + procedure Receive(Id: Integer; const Data: string); + { The gani the player shows now. } + function OwnGani: string; + { Another player by id; Make adds it when it is not known yet. } + function FindOther(Id: Integer; Make: Boolean): TServerPlayer; + procedure RemoveOther(Id: Integer); + property Others[I: Integer]: TServerPlayer read GetOther; + property OtherCount: Integer read GetOtherCount; + property Client: TAdventureClient read FClient; + property LogLines: TStrings read FLog; + property Current: TCachedLevel read GetCurrent; + end; + +{ Wall-clock milliseconds, for login and warp timings. } +function NowMs: Int64; +{ Fallback tile sheet when pics1 is not available: each tile gets a flat + colour derived from its index, so a frame still shows the board layout. } +procedure MakeIndexSheet(Sheet: TGSurface); +{ Old-style sprite prop -> pose (servers that send no GANI). } +{ X2 / Y2 / Z2 (78 to 80): a GSHORT holding abs(tiles x 16) shl 1, the + low bit the sign (graal_analysis protocol/player-props.md), so whole + pixels. } +function ToPixels2(Tiles: Double): Integer; +function FromPixels2(V: Integer): Double; +function SpriteWalkStep(Sprite: Integer): Integer; + +implementation + +uses + SysUtils, Math; + +procedure MakeIndexSheet(Sheet: TGSurface); +var + T, SX, SY: Integer; + H: Cardinal; +begin + Sheet.SetSize(128 * TileSize, 32 * TileSize); + for T := 0 to 4095 do + begin + TileSheetPos(T, SX, SY); + { Knuth's multiplicative hash, kept in 32 bits without overflowing } + H := Cardinal((Int64(T) * 2654435761) and $FFFFFFFF); + Sheet.FillRect(SX, SY, TileSize, TileSize, $FF000000 or (H shr 8)); + Sheet.FillRect(SX, SY, TileSize, 1, $FF202020); + Sheet.FillRect(SX, SY, 1, TileSize, $FF202020); + end; +end; + +{ Words split on spaces (TStrings.DelimitedText is newer than Delphi 5). } +procedure SplitSpaces(const S: string; Words: TStrings); +var + I, St: Integer; +begin + Words.Clear; + I := 1; + while I <= Length(S) do + begin + while (I <= Length(S)) and (S[I] = ' ') do Inc(I); + if I > Length(S) then Break; + St := I; + while (I <= Length(S)) and (S[I] <> ' ') do Inc(I); + Words.Add(Copy(S, St, I - St)); + end; +end; + +function EndsWith(const S, Tail: string): Boolean; +begin + Result := (Length(S) >= Length(Tail)) and + (LowerCase(Copy(S, Length(S) - Length(Tail) + 1, MaxInt)) = LowerCase(Tail)); +end; + +{ TAssets } + +constructor TAssets.Create; +begin + inherited Create; + FNames := TStringList.Create; + FNames.Sorted := True; + Missing := TStringList.Create; + Missing.Sorted := True; + Missing.Duplicates := dupIgnore; +end; + +destructor TAssets.Destroy; +var + I: Integer; +begin + for I := 0 to FNames.Count - 1 do FNames.Objects[I].Free; + FNames.Free; + Missing.Free; + inherited Destroy; +end; + +function TAssets.FindFile(const Name: string; const Dirs: array of string): string; +var + I, J, K: Integer; + Base, Cand: string; + Exts: array[0..2] of string; +begin + { the asset roots (GAssetDirs), set by UseInstall } + Result := ''; + if (AssetRootCount = 0) or (Name = '') then Exit; + Base := ChangeFileExt(Name, ''); + Exts[0] := ExtractFileExt(Name); + Exts[1] := '.png'; + Exts[2] := '.gif'; + for K := 0 to AssetRootCount - 1 do + for I := 0 to High(Dirs) do + for J := 0 to 2 do + begin + if Exts[J] = '' then Continue; + Cand := AssetRoot(K) + Dirs[I] + Base + Exts[J]; + if FileExists(Cand) then + begin + Result := Cand; + Exit; + end; + end; +end; + +function TAssets.LevelFile(const Name: string): string; +begin + Result := ''; + if (Name = '') or (Pos('..', Name) > 0) or (Pos('/', Name) > 0) or + (Pos('\', Name) > 0) then Exit; + Result := AssetPath('levels/' + Name); + if Result = '' then Result := AssetPath(Name); +end; + +function TAssets.Image(const Name, Kind: string): TGSurface; +var + Key, F, D: string; + I: Integer; + S: TGSurface; + Ok: Boolean; +begin + Result := nil; + if Name = '' then Exit; + Key := 'img:' + LowerCase(Name); + I := FNames.IndexOf(Key); + if I >= 0 then + begin + Result := TGSurface(FNames.Objects[I]); + Exit; + end; + if Kind = 'head' then F := FindFile(Name, ['levels/heads/', 'levels/', '']) + else if Kind = 'body' then F := FindFile(Name, ['levels/bodies/', 'levels/', '']) + else if Kind = 'sword' then F := FindFile(Name, ['levels/swords/', 'levels/', '']) + else if Kind = 'shield' then F := FindFile(Name, ['levels/shields/', 'levels/', '']) + else if Kind = 'hat' then F := FindFile(Name, ['levels/hats/', 'levels/', '']) + else F := FindFile(Name, ['', 'levels/', 'levels/images/']); + S := nil; + if F <> '' then + begin + S := TGSurface.Create(0, 0); + if Kind = 'body' then Ok := LoadImageIndexed(F, S) + else Ok := LoadImageFile(F, S); + if not Ok then FreeAndNil(S); + end; + { nothing on disk: the built-in default of that name, if there is one } + if (S = nil) and BuiltinFile(Name, D) then + begin + S := TGSurface.Create(0, 0); + if not LoadImageData(D, Name, S, Kind = 'body') then FreeAndNil(S); + end; + if S = nil then Missing.Add(Name); + FNames.AddObject(Key, S); + Result := S; +end; + +function TAssets.Ani(const Name: string): TGraalAni; +var + Key, F, N: string; + I: Integer; + A: TGraalAni; +begin + N := Name; + if EndsWith(N, '.gani') then SetLength(N, Length(N) - 5); + Key := 'ani:' + LowerCase(N); + I := FNames.IndexOf(Key); + if I >= 0 then + begin + Result := TGraalAni(FNames.Objects[I]); + Exit; + end; + A := nil; + if (Dir <> '') and (N <> '') and (Pos('..', N) = 0) then + begin + F := IncludeTrailingPathDelimiter(Dir) + 'levels/ganis/' + N + '.gani'; + if not FileExists(F) then + F := IncludeTrailingPathDelimiter(Dir) + 'ganis/' + N + '.gani'; + if FileExists(F) then + begin + A := TGraalAni.Create; + if not A.LoadFromFile(F) then FreeAndNil(A); + end; + end; + if (A = nil) and BuiltinFile(N + '.gani', F) then + begin + A := TGraalAni.Create; + if not A.LoadFromString(F) then FreeAndNil(A); + end; + if A = nil then Missing.Add(N + '.gani'); + FNames.AddObject(Key, A); + Result := A; +end; + +{ TGmap } + +constructor TGmap.Create; +begin + inherited Create; + Cells := TStringList.Create; +end; + +destructor TGmap.Destroy; +begin + Cells.Free; + inherited Destroy; +end; + +function TGmap.LoadFromString(const Data: string): Boolean; +var + Lines, Row: TStringList; + I, J: Integer; + S, W: string; + InNames: Boolean; +begin + Result := False; + Width := 0; + Height := 0; + Cells.Clear; + Lines := TStringList.Create; + Row := TStringList.Create; + try + Lines.Text := StringReplace(Data, #13, '', [rfReplaceAll]); + if (Lines.Count = 0) or (Trim(Lines[0]) <> 'GRMAP001') then Exit; + InNames := False; + for I := 1 to Lines.Count - 1 do + begin + S := Trim(Lines[I]); + if InNames then + begin + if S = 'LEVELNAMESEND' then + begin + InNames := False; + Continue; + end; + Row.CommaText := S; + for J := 0 to Row.Count - 1 do Cells.Add(Trim(Row[J])); + Continue; + end; + W := UpperCase(Copy(S, 1, Pos(' ', S + ' ') - 1)); + if W = 'WIDTH' then Width := StrToIntDef(Trim(Copy(S, 6, MaxInt)), 0) + else if W = 'HEIGHT' then Height := StrToIntDef(Trim(Copy(S, 7, MaxInt)), 0) + else if W = 'LEVELNAMES' then InNames := True; + end; + if (Width <= 0) or (Height <= 0) or (Width > 256) or (Height > 256) then Exit; + while Cells.Count < Width * Height do Cells.Add(''); + Result := True; + finally + Lines.Free; + Row.Free; + end; +end; + +function TGmap.CellName(CX, CY: Integer): string; +begin + Result := ''; + if (CX < 0) or (CY < 0) or (CX >= Width) or (CY >= Height) then Exit; + Result := Cells[CY * Width + CX]; +end; + +function TGmap.FindCell(const Level: string; out CX, CY: Integer): Boolean; +var + I: Integer; +begin + Result := False; + CX := 0; + CY := 0; + if Width <= 0 then Exit; + for I := 0 to Width * Height - 1 do + if (Cells[I] <> '') and (LowerCase(Cells[I]) = LowerCase(Level)) then + begin + CX := I mod Width; + CY := I div Width; + Result := True; + Exit; + end; +end; + +{ TServerPlayer } + +constructor TServerPlayer.Create; +begin + inherited Create; + { a new player: orange, darkred, black, darkred, black; body.png; head0 } + Colors[0] := 2; + Colors[1] := 5; + Colors[2] := 18; + Colors[3] := 5; + Colors[4] := 18; + BodyImage := 'body.png'; + HeadImage := 'head0.png'; + Dir := DirDown; + AniName := 'idle'; + FixedStep := -1; + Language := 'English'; +end; + +destructor TServerPlayer.Destroy; +begin + BodyCache.Free; + inherited Destroy; +end; + +{ The walk frames of the classic sprite numbers (2.05 sprite-step table): + sprite numbers 1 to 5 are walk poses. } +function ToPixels2(Tiles: Double): Integer; +var + P: Integer; +begin + P := Round(Tiles * 16); + if P < 0 then Result := ((-P) shl 1) or 1 + else Result := P shl 1; +end; + +function FromPixels2(V: Integer): Double; +begin + if (V and 1) <> 0 then Result := -(V shr 1) / 16 + else Result := (V shr 1) / 16; +end; + +function SpriteWalkStep(Sprite: Integer): Integer; +const + Steps: array[1..5] of Integer = (3, 2, 1, 0, 0); +var + S: Integer; +begin + S := Sprite div 4; + if (S >= 1) and (S <= 5) then Result := Steps[S] else Result := -1; +end; + +procedure TServerPlayer.PoseFromSprite; +var + St: Integer; +begin + St := SpriteWalkStep(Sprite); + if St >= 0 then + begin + AniName := 'walk'; + FixedStep := St; + end + else + begin + AniName := 'idle'; + FixedStep := 0; + end; +end; + +procedure TServerPlayer.SetAni(const Name: string; Frame: Integer); +begin + if Name <> AniName then + begin + AniName := Name; + AniStart := Frame; + end; +end; + +function TServerPlayer.ApplyProps(R: TGReader; Other: Boolean; Frame: Integer): string; +var + P, V, I: Integer; + S: string; +begin + Result := ''; + while not R.Eof do + begin + P := R.ReadGChar; + { the ids each 2.22 parser accepts (protocol/player-props.md) } + if Other then + begin + if (P = 1) or ((P >= 3) and (P <= 7)) or (P = 14) or (P = 22) or + ((P >= 25) and (P <= 29)) or (P = 77) or (P > 80) then Exit; + end + else if (P = 50) or (P = 51) or (P = 53) or (P = 77) or (P > 80) then Exit; + case P of + PLPROP_NICKNAME: Nickname := R.ReadGString; + PLPROP_MAXPOWER: MaxPower := R.ReadGChar; + PLPROP_CURPOWER: Power := R.ReadGChar; + PLPROP_RUPEESCOUNT: Rupees := R.ReadGInt3; + PLPROP_ARROWSCOUNT: Arrows := R.ReadGChar; + PLPROP_BOMBSCOUNT: Bombs := R.ReadGChar; + PLPROP_GLOVEPOWER: GlovePower := R.ReadGChar; + PLPROP_BOMBPOWER: BombPower := R.ReadGChar; + PLPROP_SWORDPOWER: { c(power + 30) + image, or c(power) } + begin + V := R.ReadGChar; + if V > 4 then + begin + SwordPower := V - 30; + SwordImage := R.ReadGString; + end + else + SwordPower := V; + end; + PLPROP_SHIELDPOWER: { c(power + 10) + image, or c(power) } + begin + V := R.ReadGChar; + if V > 3 then + begin + ShieldPower := V - 10; + ShieldImage := R.ReadGString; + end + else + ShieldPower := V; + end; + PLPROP_GANI: { 2.1 and later: the animation name } + begin + S := R.ReadGString; + if EndsWith(S, '.gani') then SetLength(S, Length(S) - 5); + if S <> '' then + begin + HasGani := True; + FixedStep := -1; + SetAni(S, Frame); + end; + end; + PLPROP_HEADGIF: + begin + V := R.ReadGChar; + if V >= 100 then + HeadImage := R.ReadChars(V - 100) + else + HeadImage := 'head' + IntToStr(V) + '.png'; + end; + PLPROP_CURCHAT: Chat := R.ReadGString; + PLPROP_COLORS: for I := 0 to 4 do Colors[I] := R.ReadGChar; + PLPROP_ID: Id := R.ReadGShort; + PLPROP_X: X := R.ReadGChar / 2; + PLPROP_Y: Y := R.ReadGChar / 2; + PLPROP_SPRITE: + begin + Sprite := R.ReadGChar; + Dir := Sprite mod 4; + if Other and not HasGani then PoseFromSprite; + end; + PLPROP_STATUS: Status := R.ReadGChar; + PLPROP_GMAPLEVELX: GmapX := R.ReadGChar; + PLPROP_GMAPLEVELY: GmapY := R.ReadGChar; + PLPROP_Z: Z := R.ReadGChar - 50; + PLPROP_CARRYSPRITE, PLPROP_HORSEBUSHES, PLPROP_EFFECTCOLORS, + PLPROP_MAGICPOINTS, PLPROP_ALIGNMENT, PLPROP_ADDITFLAGS, PLPROP_PSTATUSMSG: + R.ReadGChar; + PLPROP_JOINLEAVELVL: if R.ReadGChar = 0 then Gone := True; + PLPROP_CURLEVEL: Level := R.ReadGString; + PLPROP_GATTRIB1..PLPROP_GATTRIB5: + Attr[P - PLPROP_GATTRIB1 + 1] := R.ReadGString; + PLPROP_ACCOUNTNAME: Account := R.ReadGString; + PLPROP_BODYIMG: BodyImage := R.ReadGString; + PLPROP_PLANGUAGE: Language := R.ReadGString; + PLPROP_OSTYPE: OsType := R.ReadGString; + PLPROP_TEXTCODEPAGE: CodePage := R.ReadGInt3; + PLPROP_X2: X := FromPixels2(R.ReadGShort); + PLPROP_Y2: Y := FromPixels2(R.ReadGShort); + PLPROP_Z2: Z := Round(FromPixels2(R.ReadGShort)); + PLPROP_HORSEGIF, PLPROP_GATTRIB6..PLPROP_GATTRIB9, + PLPROP_GATTRIB10..PLPROP_GATTRIB30: + R.ReadGString; + PLPROP_CARRYNPC, PLPROP_KILLSCOUNT, PLPROP_DEATHSCOUNT, + PLPROP_ONLINESECS, PLPROP_UDPPORT, PLPROP_RATING: + R.ReadGInt3; + PLPROP_APCOUNTER: R.ReadGShort; + PLPROP_IPADDR: R.ReadGInt5; + PLPROP_ATTACHNPC: + begin + R.ReadGChar; + R.ReadGInt3; + end; + PLPROP_PCONNECTED: + begin + Gone := True; + if not R.Eof then R.ReadByte; + end; + else + Exit; { unknown size: the rest of the stream is lost } + end; + if R.Overrun then Exit; + if Result <> '' then Result := Result + ','; + Result := Result + IntToStr(P); + end; +end; + +{ TAdventure } + +constructor TAdventure.Create; +begin + inherited Create; + FLog := TStringList.Create; + LoginMs := -1; + UseWallClock := True; + ServerName := FirstServerName; + FClient := TAdventureClient.Create; + FClient.OnMessage := HandleMessage; + FClient.OnLog := ClientLog; + FLevels := TStringList.Create; + FLevels.Sorted := True; + FAdjacentAsked := TStringList.Create; + FAdjacentAsked.Sorted := True; + FAdjacentAsked.Duplicates := dupIgnore; + Level := CachedLevel('', True); + Player := TServerPlayer.Create; + Screen := TGSurface.Create(ScreenW, ScreenH); + Sheet := TGSurface.Create(0, 0); + Arrays := TGArrays.Create; + Assets := TAssets.Create; + FOthers := TList.Create; + FTileDefs := TStringList.Create; + UseBuiltins; +end; + +procedure TAdventure.UseBuiltins; +var + D: string; +begin + if BuiltinFile('pics1.png', D) and LoadImageData(D, 'pics1.png', Sheet, False) then + SheetBuiltin := True; + if BuiltinFile('arrays.dat', D) then Arrays.LoadFromString(D); +end; + +destructor TAdventure.Destroy; +var + I: Integer; +begin + FClient.Free; + for I := 0 to FLevels.Count - 1 do FLevels.Objects[I].Free; + FLevels.Free; + FAdjacentAsked.Free; + Gmap.Free; + Player.Free; + Screen.Free; + Sheet.Free; + Arrays.Free; + Assets.Free; + for I := 0 to FOthers.Count - 1 do TServerPlayer(FOthers[I]).Free; + FOthers.Free; + FTileDefs.Free; + FLog.Free; + inherited Destroy; +end; + +function NowMs: Int64; +begin + Result := Trunc(Now * 86400000.0); +end; + +{ A duration in ms that fits an Integer, whatever the clock did. } +function ClampMs(V: Int64): Integer; +begin + if V < 0 then Result := 0 + else if V > MaxInt then Result := MaxInt + else Result := V; +end; + +const + LogKeep = 1000; + +procedure TAdventure.Log(const S: string); +var + Line: string; +begin + Line := Format('[%5d] %s', [Frame, S]); + if Echo then WriteLn(ErrOutput, Line); + if FLog.Count >= LogKeep then FLog.Delete(0); + FLog.Add(Line); +end; + +procedure TAdventure.ClientLog(const Line: string); +begin + Log(Line); +end; + +function TAdventure.GetCurrent: TCachedLevel; +begin + Result := Level; +end; + +function TAdventure.CachedLevel(const Name: string; Make: Boolean): TCachedLevel; +var + I: Integer; +begin + I := FLevels.IndexOf(LowerCase(Name)); + if I >= 0 then + begin + Result := TCachedLevel(FLevels.Objects[I]); + Exit; + end; + Result := nil; + if not Make then Exit; + Result := TCachedLevel.Create; + Result.Name := Name; + FLevels.AddObject(LowerCase(Name), Result); +end; + +procedure TAdventure.UseInstall(const Dir: string); +var + P: string; +begin + Assets.Dir := Dir; + { the folder itself, then graal-assets// and graal-assets/common/ } + SetAssetRoots(Dir, ClientBuildLabel); + if AssetsFolder <> '' then Log('assets: ' + AssetsFolder); + { the install's tile sheet and tile types replace the built-in ones, but + not a sheet given with --sheet } + if (Sheet.Width = 0) or SheetBuiltin then + begin + P := AssetPath('pics1.png'); + if P = '' then P := AssetPath('pics1.gif'); + if (P <> '') and LoadImageFile(P, Sheet) then SheetBuiltin := False; + end; + P := AssetPath('arrays.dat'); + if (P <> '') and Arrays.LoadFromFile(P) then + Log('arrays.dat loaded') + else + Log('arrays.dat not found in ' + Dir + ': using the built-in tile types'); +end; + +function TAdventure.ConnectServer(const Host: string; Port: Word; + const Account, Password: string): Boolean; +begin + FHost := Host; + FPort := Port; + FAccount := Account; + FPassword := Password; + ConnectAtMs := NowMs; + LoginMs := -1; + Result := FClient.Connect(Host, Port); + if not Result then + begin + Log('connect failed: ' + FClient.LastError); + Exit; + end; + Log(Format('connected to %s:%d (server %s), key %d, token %s', [Host, Port, + ServerName, FClient.Key, ClientVersionToken])); + FClient.SendLogin(Account, Password, 'English'); + FClient.Flush; +end; + +{ ---- walking (client-internals/decomp-findings-2026-10-25-m/01-walking-rule.md; + run-222d shows 2.22 moving 0.5 a frame, as 2.05 does) ---- } + +function TileOf(V: Double): Integer; +begin + Result := Floor(V + 0.0001); +end; + +function TAdventure.WorldTile(GX, GY: Integer): Integer; +var + CX, CY: Integer; + L: TCachedLevel; +begin + Result := -1; + if Gmap = nil then + begin + if (GX < 0) or (GY < 0) or (GX >= BoardW) or (GY >= BoardH) then Exit; + Result := Level.Tile(GX, GY); + Exit; + end; + if (GX < 0) or (GY < 0) then Exit; + CX := GX div BoardW; + CY := GY div BoardH; + L := CachedLevel(Gmap.CellName(CX, CY), False); + if (L = nil) or (Gmap.CellName(CX, CY) = '') then Exit; + Result := L.Tile(GX - CX * BoardW, GY - CY * BoardH); +end; + +function TAdventure.PointBlocked(PX, PY: Double): Boolean; +var + TX, TY, I, T: Integer; +begin + Result := False; + { chests: x, y to x + 2, y + 2, edges included, opened or not } + for I := 0 to High(Level.Chests) do + if (PX >= Level.Chests[I].X) and (PX <= Level.Chests[I].X + 2) and + (PY >= Level.Chests[I].Y) and (PY <= Level.Chests[I].Y + 2) then + begin + Result := True; + Exit; + end; + TX := TileOf(PX); + TY := TileOf(PY); + if Gmap = nil then + begin + { off a gmap the edge is open, so level links can be reached (as in + 2.05; run-222d: the player reaches x = -0.5 on the level's left + edge) } + if (TX < 0) or (TY < 0) or (TX >= BoardW) or (TY >= BoardH) then Exit; + Result := not Arrays.TilePassable(Level.Tile(TX, TY)); + Exit; + end; + { on a gmap the neighbours' boards decide; the outer edge of the map + and cells whose level has not arrived are walls (not measured) } + T := WorldTile(TX + Player.GmapX * BoardW, TY + Player.GmapY * BoardH); + if T < 0 then Result := True + else Result := not Arrays.TilePassable(T); +end; + +procedure TAdventure.WalkStep(Dir: Integer); +const + StepX: array[0..3] of Double = (0, -0.5, 0, 0.5); + StepY: array[0..3] of Double = (-0.5, 0, 0.5, 0); + { probe offsets from the sprite's top-left: fixed axis, then six points } + Fixed: array[0..3] of Double = (1.0, 0.5, 3.0, 2.5); + Along: array[0..3, 0..5] of Double = ( + (0.525, 1.475, 1.525, 2.475, 2.525, 0.475), + (1.025, 1.975, 2.025, 2.975, 3.025, 0.975), + (0.525, 1.475, 1.525, 2.475, 2.525, 0.475), + (1.025, 1.975, 2.025, 2.975, 3.025, 0.975)); + Speed = 1.0; { on foot } +var + NX, NY, F: Double; + B: array[0..5] of Boolean; + I: Integer; +begin + Player.Dir := Dir; + NX := Player.X + StepX[Dir] * Speed; + NY := Player.Y + StepY[Dir] * Speed; + for I := 0 to 5 do + if (Dir = DirUp) or (Dir = DirDown) then + B[I] := PointBlocked(NX + Along[Dir, I], NY + Fixed[Dir]) + else + B[I] := PointBlocked(NX + Fixed[Dir], NY + Along[Dir, I]); + if B[0] or B[1] or B[2] or B[3] then + begin + { 1. corner nudge } + if B[0] and not B[2] and not B[3] and not B[4] then + begin + if (Dir = DirUp) or (Dir = DirDown) then NX := NX + 0.1 else NY := NY + 0.1; + end + else if not B[0] and not B[1] and B[3] and not B[5] then + begin + if (Dir = DirUp) or (Dir = DirDown) then NX := NX - 0.1 else NY := NY - 0.1; + end; + { 2. take the step back, the nudge stays } + NX := NX - StepX[Dir] * Speed; + NY := NY - StepY[Dir] * Speed; + { 3. flush snap along the facing, when the fraction is above zero } + case Dir of + DirUp: if Frac(NY) > 0 then NY := Floor(NY); + DirLeft: if Frac(NX + 0.5) > 0 then NX := Floor(NX + 0.5) - 0.5; + DirDown: if Frac(NY) > 0 then NY := Floor(NY + 1); + DirRight: if Frac(NX + 0.5) > 0 then NX := Floor(NX + 1.5) - 0.5; + end; + end; + { after every step: snap out of the thin band at a tile line } + F := NY - Floor(NY); + if (F < 0.0625) or (F > 0.9375) then NY := Floor(NY + 0.0625); + F := (NX + 0.5) - Floor(NX + 0.5); + if (F < 0.0625) or (F > 0.9375) then NX := Floor(NX + 0.5 + 0.0625) - 0.5; + Player.X := NX; + Player.Y := NY; +end; + +{ ---- other players ---- } + +function TAdventure.GetOther(I: Integer): TServerPlayer; +begin + Result := TServerPlayer(FOthers[I]); +end; + +function TAdventure.GetOtherCount: Integer; +begin + Result := FOthers.Count; +end; + +function TAdventure.FindOther(Id: Integer; Make: Boolean): TServerPlayer; +var + I: Integer; +begin + for I := 0 to FOthers.Count - 1 do + begin + Result := TServerPlayer(FOthers[I]); + if Result.Id = Id then Exit; + end; + Result := nil; + if not Make then Exit; + Result := TServerPlayer.Create; + Result.Id := Id; + Result.FixedStep := 0; + FOthers.Add(Result); +end; + +procedure TAdventure.RemoveOther(Id: Integer); +var + P: TServerPlayer; +begin + P := FindOther(Id, False); + if P = nil then Exit; + FOthers.Remove(P); + P.Free; +end; + +{ ---- levels, gmaps, links ---- } + +function ReadFileText(const FileName: string; out Data: string): Boolean; +var + F: TFileStream; +begin + Result := False; + Data := ''; + try + F := TFileStream.Create(FileName, fmOpenRead or fmShareDenyNone); + try + SetLength(Data, F.Size); + if F.Size > 0 then F.ReadBuffer(Data[1], F.Size); + Result := True; + finally + F.Free; + end; + except + Result := False; + end; +end; + +procedure TAdventure.SetGmap(const Name: string); +var + F, Data: string; +begin + if (Gmap <> nil) and (LowerCase(Gmap.Name) = LowerCase(Name)) then Exit; + GmapName := Name; + FreeAndNil(Gmap); + FAdjacentAsked.Clear; + { the install (or the folder of an offline level) first, then the server } + F := ''; + if (FLevelDir <> '') and FileExists(FLevelDir + Name) then F := FLevelDir + Name + else F := Assets.LevelFile(Name); + if (F <> '') and ReadFileText(F, Data) then + begin + Gmap := TGmap.Create; + Gmap.Name := Name; + if not Gmap.LoadFromString(Data) then + begin + Log('gmap ' + Name + ': not a GRMAP001 file'); + FreeAndNil(Gmap); + end; + end; + if (Gmap = nil) and FClient.Connected and (FGmapWanted <> Name) then + begin + FClient.SendPacket(PLI_WANTFILE, Name); + FGmapWanted := Name; + Log('WANTFILE ' + Name); + end; + if Gmap <> nil then + Log(Format('gmap %s: %dx%d', [Name, Gmap.Width, Gmap.Height])); +end; + +{ PLI_ADJACENTLEVEL for the 3x3 neighbourhood, the current cell skipped, + in row order (lan-222m): i5 mod time (0 when not cached) + name. } +procedure TAdventure.AskAdjacent; +var + DX, DY: Integer; + N: string; + L: TCachedLevel; + MT: Cardinal; +begin + if (Gmap = nil) or not FClient.Connected then Exit; + for DX := -1 to 1 do + for DY := -1 to 1 do + begin + if (DX = 0) and (DY = 0) then Continue; + N := Gmap.CellName(Player.GmapX + DX, Player.GmapY + DY); + if N = '' then Continue; + if FAdjacentAsked.IndexOf(LowerCase(N)) >= 0 then Continue; + FAdjacentAsked.Add(LowerCase(N)); + L := CachedLevel(N, False); + MT := 0; + if (L <> nil) and L.HasModTime and L.HasBoard then MT := L.ModTime; + FClient.SendPacket(PLI_ADJACENTLEVEL, GInt5(MT) + N); + end; +end; + +function TAdventure.LoadLevelFile(const FileName: string): Boolean; +var + Data, N, P, D: string; + CX, CY: Integer; + L: TCachedLevel; +begin + Result := False; + FLevelDir := ExtractFilePath(FileName); + if EndsWith(FileName, '.gmap') then + begin + SetGmap(ExtractFileName(FileName)); + if Gmap = nil then + begin + Level.LastError := 'cannot read the gmap'; + Exit; + end; + { every cell's level from the same folder } + for CY := 0 to Gmap.Height - 1 do + for CX := 0 to Gmap.Width - 1 do + begin + N := Gmap.CellName(CX, CY); + if N = '' then Continue; + P := FLevelDir + N; + if not FileExists(P) then P := Assets.LevelFile(N); + L := CachedLevel(N, True); + if (P <> '') and L.LoadFromFile(P) then L.HasBoard := True; + L.Name := N; + end; + Player.GmapX := 0; + Player.GmapY := 0; + Level := CachedLevel(Gmap.CellName(0, 0), True); + Player.Level := GmapName; + Result := Level.HasBoard; + Exit; + end; + FreeAndNil(Gmap); + GmapName := ''; + L := CachedLevel(ExtractFileName(FileName), True); + if not FileExists(FileName) and BuiltinFile(ExtractFileName(FileName), D) and + (LowerCase(ExtractFileExt(FileName)) <> '.png') then + begin + { a built-in level: links from it look in the install, then here } + Result := L.LoadFromString(D); + FLevelDir := ''; + end + else + Result := L.LoadFromFile(FileName); + L.HasBoard := Result; + L.Name := ExtractFileName(FileName); + if not Result then Level.LastError := L.LastError; + if Result then Level := L; + Player.Level := Level.Name; +end; + +function TAdventure.LinkAt(PX, PY: Double): Integer; +var + I: Integer; + L: TLevelLink; +begin + for I := 0 to High(Level.Links) do + begin + L := Level.Links[I]; + if (PX >= L.X) and (PX < L.X + L.W) and (PY >= L.Y) and (PY < L.Y + L.H) then + begin + Result := I; + Exit; + end; + end; + Result := -1; +end; + +{ An arrival is a number, or playerx / playery (or a negative number, "-1" + in 2.22's own reading) for "keep the player's coordinate". } +function Arrival(const S: string; Keep: Double): Double; +var + V: Double; +begin + Result := Keep; + if (S = '') or (LowerCase(Copy(S, 1, 6)) = 'player') then Exit; + if not TryStrToFloat(S, V) then Exit; + if V >= 0 then Result := V; +end; + +function TAdventure.FollowLink(I: Integer): Boolean; +var + L: TLevelLink; + NX, NY: Double; + Path: string; + C: TCachedLevel; +begin + Result := False; + if (I < 0) or (I > High(Level.Links)) then Exit; + L := Level.Links[I]; + NX := Arrival(L.NewX, Player.X); + NY := Arrival(L.NewY, Player.Y); + if FClient.Connected then + begin + if FWarpPending then Exit; + { 2.22 asks with LEVELWARPMOD when it holds the level (its mod time + first), else with LEVELWARP; 5.00r7 is taken to do the same, with no + tamper check after it } + C := CachedLevel(L.Dest, False); + if (C <> nil) and C.HasModTime and C.HasBoard then + FClient.SendPacket(PLI_LEVELWARPMOD, GInt5(C.ModTime) + + GChar(Round(NX * 2)) + GChar(Round(NY * 2)) + L.Dest) + else + FClient.SendPacket(PLI_LEVELWARP, GChar(Round(NX * 2)) + + GChar(Round(NY * 2)) + L.Dest); + FWarpPending := True; + FWarpX := NX; + FWarpY := NY; + FWarpLevel := L.Dest; + Inc(WarpsSent); + FWarpTimed := L.Dest; + FWarpT0 := NowMs; + Log(Format('LEVELWARP %s %.1f,%.1f', [L.Dest, NX, NY])); + Result := True; + Exit; + end; + Path := ''; + if (FLevelDir <> '') and FileExists(FLevelDir + L.Dest) then + Path := FLevelDir + L.Dest + else + Path := Assets.LevelFile(L.Dest); + if Path = '' then Path := L.Dest; { LoadLevelFile tries the built-in ones } + if not LoadLevelFile(Path) then + begin + Log('link to ' + L.Dest + ': ' + Level.LastError); + Exit; + end; + if Gmap <> nil then + begin + { a link into a gmap: the arrival is in that map's first cell } + Player.GmapX := 0; + Player.GmapY := 0; + end; + Player.X := NX; + Player.Y := NY; + Log(Format('link to %s at %.1f,%.1f', [Level.Name, NX, NY])); + Result := True; +end; + +{ A timed link warp has its board: one more warp time. } +procedure TAdventure.WarpDone; +begin + if FWarpTimed = '' then Exit; + if WarpCount = Length(WarpTimes) then + SetLength(WarpTimes, 2 * WarpCount + 16); + WarpTimes[WarpCount] := ClampMs(NowMs - FWarpT0); + Inc(WarpCount); + FWarpTimed := ''; +end; + +{ ---- gmap edges (06-gmap-overworld.md, the 2.22 lab capture): crossing is + client-driven; the wrapped local position and the changed cell prop go + out in one props message, and 2.22 re-sends the tamper check ---- } + +procedure TAdventure.CrossEdges; +var + Crossed: Boolean; + N: string; +begin + if Gmap = nil then Exit; + Crossed := False; + if (Player.X >= BoardW) and (Gmap.CellName(Player.GmapX + 1, Player.GmapY) <> '') then + begin + Player.X := Player.X - BoardW; + Inc(Player.GmapX); + Crossed := True; + end + else if (Player.X < 0) and (Gmap.CellName(Player.GmapX - 1, Player.GmapY) <> '') then + begin + Player.X := Player.X + BoardW; + Dec(Player.GmapX); + Crossed := True; + end; + if (Player.Y >= BoardH) and (Gmap.CellName(Player.GmapX, Player.GmapY + 1) <> '') then + begin + Player.Y := Player.Y - BoardH; + Inc(Player.GmapY); + Crossed := True; + end + else if (Player.Y < 0) and (Gmap.CellName(Player.GmapX, Player.GmapY - 1) <> '') then + begin + Player.Y := Player.Y + BoardH; + Dec(Player.GmapY); + Crossed := True; + end; + if not Crossed then Exit; + Inc(EdgeCrossings); + N := Gmap.CellName(Player.GmapX, Player.GmapY); + Level := CachedLevel(N, True); + Level.Name := N; + BoardLoaded := Level.HasBoard; + while FOthers.Count > 0 do RemoveOther(Others[0].Id); + Log(Format('crossed into %s (cell %d,%d)', [N, Player.GmapX, Player.GmapY])); + if FClient.Connected then + AskAdjacent; +end; + +{ ---- props to the server ---- } + +function TAdventure.OwnGani: string; +begin + Result := Player.AniName; +end; + +{ The first client frame after the login burst. The lab saw 5.x send its + own props as nickname, colours, language, OSTYPE (win) and then the + position (protocol/v5v6-lab-play.md, "Client"); the position goes as + X2 / Y2. Then UPDATEFILE for the player's head, and ADJACENTLEVEL on a + gmap. The base-file requests the real client makes (basepackage.gupd + by 47 or 23) are not sent. } +procedure TAdventure.SendLoginFrame; +var + F: string; + MT: Cardinal; + I: Integer; + Cols: string; +begin + Cols := ''; + for I := 0 to 4 do Cols := Cols + GChar(Player.Colors[I]); + FClient.SendPacket(PLI_PLAYERPROPS, + GChar(PLPROP_NICKNAME) + GString(Player.Nickname) + + GChar(PLPROP_COLORS) + Cols + + GChar(PLPROP_PLANGUAGE) + GString(Player.Language) + + GChar(PLPROP_OSTYPE) + GString(OsType) + + GChar(PLPROP_X2) + GShort(ToPixels2(Player.X)) + + GChar(PLPROP_Y2) + GShort(ToPixels2(Player.Y))); + if Player.HeadImage <> '' then + begin + MT := 0; + F := Assets.FindFile(Player.HeadImage, ['', 'levels/', 'levels/heads/']); + if F <> '' then + MT := Cardinal(Round((FileDateToDateTime(FileAge(F)) - 25569.0) * 86400.0)); + FClient.SendPacket(PLI_UPDATEFILE, GInt5(MT) + Player.HeadImage); + end; + AskAdjacent; + FSentX := Player.X; + FSentY := Player.Y; + FSentDir := Player.Dir; + FSentGani := OwnGani; + FSentGmapX := Player.GmapX; + FSentGmapY := Player.GmapY; + FPropsSent := True; +end; + +procedure TAdventure.SendMovedProps; +var + S, G: string; +begin + { a diff of the changed props, in id order, every tick (50 ms): the lab + saw 5.x send only the coordinate that changed, as X2 or Y2, each tick + while walking, with the gani change in the same message as the first + step (lab-v5-2026-10-30.md, "Movement") } + if not FPropsSent then Exit; + S := ''; + G := OwnGani; + if G <> FSentGani then S := S + GChar(PLPROP_GANI) + GString(G); + if Player.Dir <> FSentDir then S := S + GChar(PLPROP_SPRITE) + GChar(Player.Dir); + if Player.GmapX <> FSentGmapX then S := S + GChar(PLPROP_GMAPLEVELX) + GChar(Player.GmapX); + if Player.GmapY <> FSentGmapY then S := S + GChar(PLPROP_GMAPLEVELY) + GChar(Player.GmapY); + if Player.X <> FSentX then S := S + GChar(PLPROP_X2) + GShort(ToPixels2(Player.X)); + if Player.Y <> FSentY then S := S + GChar(PLPROP_Y2) + GShort(ToPixels2(Player.Y)); + if S = '' then Exit; + FClient.SendPacket(PLI_PLAYERPROPS, S); + FSentX := Player.X; + FSentY := Player.Y; + FSentDir := Player.Dir; + FSentGani := G; + FSentGmapX := Player.GmapX; + FSentGmapY := Player.GmapY; +end; + +function TAdventure.LoginMode: Boolean; +begin + Result := LowerCase(Copy(ServerName, 1, 5)) = 'login'; +end; + +{ PLO_LISTPROCESSES (182): the real client answers with 44 and a comma + list of what runs on the machine (the lab saw window titles). The + rebuild names only its own game window, the server's name. } +procedure TAdventure.ListProcesses; +begin + FClient.SendPacket(PLI_PROCESSLIST, ServerName); +end; + +{ ---- messages from the server ---- } + +procedure TAdventure.Receive(Id: Integer; const Data: string); +begin + HandleMessage(Id, Data); +end; + +{ PLO_FILE (102, behind RAWDATA): i5 mod time, c name length, name, data + (2.22 gets file mod times; version-profiles/2.22-2.31.md). Only a .gmap + is kept; other files are not saved yet. } +procedure TAdventure.ReceiveFile(const Data: string); +var + R: TGReader; + Name, Body: string; +begin + R := TGReader.Create(Data); + try + R.ReadGInt5; + Name := R.ReadGString; + Body := R.ReadRest; + finally + R.Free; + end; + Log(Format('FILE %s (%d bytes)', [Name, Length(Body)])); + if EndsWith(Name, '.gmap') and (LowerCase(Name) = LowerCase(GmapName)) then + begin + FreeAndNil(Gmap); + Gmap := TGmap.Create; + Gmap.Name := Name; + if not Gmap.LoadFromString(Body) then + begin + Log('gmap ' + Name + ': not a GRMAP001 file'); + FreeAndNil(Gmap); + Exit; + end; + Log(Format('gmap %s: %dx%d', [Name, Gmap.Width, Gmap.Height])); + if FPropsSent then AskAdjacent; + end; +end; + +{ PLO_SERVERWARP (178): "x,name,host,port", split on commas only (the + lab's unquoted "0,Lab Server,,14900" kept the whole name); the + client closes the link, logs in there with a new key and the same + account, and the name becomes the server's name, which ends Login mode + (lab-v5-2026-10-30.md). Fewer fields: ignored. } +procedure TAdventure.ServerWarp(const Data: string); +var + F: TStringList; + Port: Integer; + Rest: string; + P: Integer; +begin + F := TStringList.Create; + try + Rest := Data; + while Rest <> '' do + begin + P := Pos(',', Rest); + if P = 0 then + begin + F.Add(Rest); + Rest := ''; + end + else + begin + F.Add(Copy(Rest, 1, P - 1)); + Delete(Rest, 1, P); + end; + end; + if F.Count < 4 then Exit; + Port := StrToIntDef(Trim(F[3]), -1); + if (Port <= 0) or (Port > 65535) or (Trim(F[2]) = '') then + begin + Log('SERVERWARP: bad host or port'); + Exit; + end; + Log(Format('SERVERWARP to %s %s:%d', [F[1], Trim(F[2]), Port])); + Inc(ServerWarps); + FClient.Flush; + FClient.Disconnect; + LoggedIn := False; + BoardLoaded := False; + FPropsSent := False; + FWarpPending := False; + while FOthers.Count > 0 do RemoveOther(Others[0].Id); + ServerName := F[1]; + ConnectServer(Trim(F[2]), Port, FAccount, FPassword); + finally + F.Free; + end; +end; + +procedure TAdventure.HandleMessage(Id: Integer; const Data: string); +var + R: TGReader; + S: string; + V, I, X0, Y0, W, H, MX, MY: Integer; + L: TLevelLink; + SG: TLevelSign; + CH: TLevelChest; + Words: TStringList; + OP: TServerPlayer; + T: TCachedLevel; + Replaced: Boolean; +begin + if not PLOKnown(Id) then + begin + { 2.22 has no case for it: silently ignored } + if (Id >= 0) and (Id <= 255) then Inc(Ignored[Id]); + Exit; + end; + R := TGReader.Create(Data); + try + case Id of + PLO_PLAYERPROPS: + begin + S := Player.ApplyProps(R, False, Frame); + Log('PLAYERPROPS ' + S); + if not LoggedIn then LoggedIn := True; + end; + PLO_OTHERPLPROPS: { s id + prop stream; an unknown id adds the player } + begin + if Length(Data) < 2 then Exit; + V := R.ReadGShort; + OP := FindOther(V, True); + OP.ApplyProps(R, True, Frame); + if OP.Gone then RemoveOther(V); + end; + PLO_PLAYERWARP: { c x*2, c y*2, level } + begin + Player.X := R.ReadGChar / 2; + Player.Y := R.ReadGChar / 2; + Player.Level := R.ReadRest; + FWarpPending := False; + FSentX := Player.X; + FSentY := Player.Y; + if not EndsWith(Player.Level, '.gmap') then + begin + FreeAndNil(Gmap); + GmapName := ''; + end; + Log(Format('PLAYERWARP %s %.1f,%.1f', [Player.Level, Player.X, Player.Y])); + end; + PLO_PLAYERWARP2: { c x*2, c y*2, c z, c gmap x, c gmap y, level } + begin + Player.X := R.ReadGChar / 2; + Player.Y := R.ReadGChar / 2; + R.ReadGChar; { z: not read by 2.22 } + MX := R.ReadGChar; + MY := R.ReadGChar; + Player.Level := R.ReadRest; + FWarpPending := False; + FSentX := Player.X; + FSentY := Player.Y; + if EndsWith(Player.Level, '.gmap') then + begin + SetGmap(Player.Level); + if Gmap <> nil then + begin + { clamped to the grid } + MX := Max(0, Min(MX, Gmap.Width - 1)); + MY := Max(0, Min(MY, Gmap.Height - 1)); + end; + Player.GmapX := MX; + Player.GmapY := MY; + FSentGmapX := MX; + FSentGmapY := MY; + if Gmap <> nil then + begin + Level := CachedLevel(Gmap.CellName(MX, MY), True); + Level.Name := Gmap.CellName(MX, MY); + end; + end; + Log(Format('PLAYERWARP2 %s %.1f,%.1f cell %d,%d', [Player.Level, Player.X, + Player.Y, MX, MY])); + end; + PLO_LEVELNAME: + begin + if EndsWith(Data, '.gmap') then + begin + { the "named level" goes back to the gmap after a level's data } + SetGmap(Data); + end + else + begin + T := CachedLevel(Data, True); + T.Name := Data; + if FWarpPending and (Data = FWarpLevel) then + begin + { the server sends no PLAYERWARP for a link: the client + completes its own pending warp when the level arrives } + while FOthers.Count > 0 do RemoveOther(Others[0].Id); + Player.X := FWarpX; + Player.Y := FWarpY; + Player.Level := Data; + FWarpPending := False; + FreeAndNil(Gmap); + GmapName := ''; + Level := T; + BoardLoaded := T.HasBoard; + if BoardLoaded then + WarpDone; + end + else if (Gmap = nil) or (LowerCase(Gmap.CellName(Player.GmapX, Player.GmapY)) = + LowerCase(Data)) or (GmapName = '') then + begin + if Level <> T then + begin + while FOthers.Count > 0 do RemoveOther(Others[0].Id); + Level := T; + BoardLoaded := T.HasBoard; + end; + end; + { a neighbour's data goes to its own cached level } + FCurrentData := T; + end; + Log('LEVELNAME ' + Data); + end; + PLO_BOARDPACKET: + begin + T := FCurrentData; + if T = nil then T := Level; + if T.LoadBoardPacket(Data) then + begin + T.HasBoard := True; + SetLength(T.Links, 0); + SetLength(T.Signs, 0); + end; + if T = Level then BoardLoaded := T.HasBoard; + if BoardLoaded and LoggedIn and (LoginMs < 0) and (ConnectAtMs > 0) then + LoginMs := ClampMs(NowMs - ConnectAtMs); + if T.HasBoard and (FWarpTimed <> '') and (LowerCase(T.Name) = LowerCase(FWarpTimed)) then + WarpDone; + if T.HasBoard then + Log('BOARDPACKET ' + T.Name + ' loaded') + else + Log('BOARDPACKET rejected: ' + T.LastError); + end; + PLO_LEVELBOARD: ; { empty in 2.2x bursts; the board comes as 101 } + PLO_LEVELMODTIME: + begin + T := FCurrentData; + if T = nil then T := Level; + T.ModTime := R.ReadGInt5; + T.HasModTime := not R.Overrun; + end; + PLO_LEVELLINK: { "dest x y w h newx newy" as text } + begin + T := FCurrentData; + if T = nil then T := Level; + Words := TStringList.Create; + try + SplitSpaces(Data, Words); + if Words.Count >= 5 then + begin + L.Dest := Words[0]; + L.X := Trunc(StrToFloatDef(Words[1], 0)); + L.Y := Trunc(StrToFloatDef(Words[2], 0)); + L.W := Trunc(StrToFloatDef(Words[3], 0)); + L.H := Trunc(StrToFloatDef(Words[4], 0)); + L.NewX := 'playerx'; + L.NewY := 'playery'; + if Words.Count >= 6 then L.NewX := Words[5]; + if Words.Count >= 7 then L.NewY := Words[6]; + if L.NewX = '-1' then L.NewX := 'playerx'; + if L.NewY = '-1' then L.NewY := 'playery'; + SetLength(T.Links, Length(T.Links) + 1); + T.Links[High(T.Links)] := L; + end; + finally + Words.Free; + end; + end; + PLO_LEVELSIGN: + begin + T := FCurrentData; + if T = nil then T := Level; + SG.X := R.ReadGChar; + SG.Y := R.ReadGChar; + SG.Text := DecodeSignText(R.ReadRest); + SetLength(T.Signs, Length(T.Signs) + 1); + T.Signs[High(T.Signs)] := SG; + end; + PLO_LEVELCHEST: { c opened, c x, c y, c item, c sign } + begin + T := FCurrentData; + if T = nil then T := Level; + R.ReadGChar; + CH.X := R.ReadGChar; + CH.Y := R.ReadGChar; + CH.Item := R.ReadGChar; + CH.Sign := R.ReadGChar; + { a chest is sent on every visit: one per position } + Replaced := False; + for I := 0 to High(T.Chests) do + if (T.Chests[I].X = CH.X) and (T.Chests[I].Y = CH.Y) then + begin + T.Chests[I] := CH; + Replaced := True; + end; + if not Replaced then + begin + SetLength(T.Chests, Length(T.Chests) + 1); + T.Chests[High(T.Chests)] := CH; + end; + end; + PLO_BOARDMODIFY, PLO_BOARDMODIFY2: + begin + { 7: c x, c y, c w, c h, w*h s tiles; 186: c map x, c map y first + (packet-ids.md); a short payload is dropped } + T := Level; + if Id = PLO_BOARDMODIFY2 then + begin + MX := R.ReadGChar; + MY := R.ReadGChar; + if Gmap <> nil then + begin + T := CachedLevel(Gmap.CellName(MX, MY), False); + if Gmap.CellName(MX, MY) = '' then T := nil; + end; + end; + X0 := R.ReadGChar; + Y0 := R.ReadGChar; + W := R.ReadGChar; + H := R.ReadGChar; + if (T <> nil) and (R.Remaining >= 2 * W * H) then + for I := 0 to W * H - 1 do + begin + V := R.ReadGShort; + if (X0 + I mod W < BoardW) and (Y0 + I div W < BoardH) then + T.Tiles[(Y0 + I div W) * BoardW + X0 + I mod W] := V; + end; + end; + PLO_SIGNATURE: { 1: quit; 0: quit unless the host is loopback } + begin + V := R.ReadGChar; + Log('SIGNATURE ' + IntToStr(V)); + if (V = 1) or ((V = 0) and (FHost <> '127.0.0.1') and (FHost <> 'localhost')) then + begin + DisconnectReason := 'signature ' + IntToStr(V); + FClient.Disconnect; + end; + end; + PLO_NEWWORLDTIME: WorldTime := R.ReadGInt4; + PLO_STARTMESSAGE: ServerMessage := Data; + PLO_DISCMESSAGE: + begin + DisconnectReason := Data; + Log('DISCMESSAGE ' + Data); + end; + PLO_WARPFAILED: + begin + FWarpPending := False; + Log('WARPFAILED ' + Data); + end; + PLO_FILE: ReceiveFile(Data); + PLO_SETACTIVELEVEL: + begin + if EndsWith(Data, '.gmap') then SetGmap(Data); + FCurrentData := nil; + Log('SETACTIVELEVEL ' + Data); + end; + PLO_FREEZEPLAYER2: Frozen := True; + PLO_UNFREEZEPLAYER: Frozen := False; + PLO_SERVERWARP: ServerWarp(Data); + PLO_LISTPROCESSES: ListProcesses; + PLO_TOALL: Log('TOALL ' + Data); + else + ; { handled by 2.22; their effects belong to later stages } + end; + if (Id >= 0) and (Id <= 255) then Inc(Handled[Id]); + finally + R.Free; + end; +end; + +{ ---- the frame ---- } + +{ How far ahead of the body's centre the link is tested. Measured on 2.05; + run-222d's left-edge probe on 2.22 (warps from y 31.5 and 32, none from + 32.5) fits the same point. } +const + LinkAhead = 1.25; + +procedure TAdventure.Tick; +var + D: Integer; + Moved: Boolean; + AX, AY: Double; +begin + Inc(Frame); + if UseWallClock then ClockMs := NowMs; + if FClient.Connected then + begin + FClient.Poll; + if not FClient.Connected then + Log('link closed: ' + FClient.LastError); + end; + { the first frame after the login burst } + if LoggedIn and not FPropsSent and FClient.Connected then SendLoginFrame; + { keys run in the order up, left, down, right, each from where the + earlier ones left the player } + Moved := False; + AX := 0; + AY := 0; + if not Frozen then + for D := 0 to 3 do + if Keys[D] then + begin + WalkStep(D); + Moved := True; + case D of + DirUp: AY := AY - LinkAhead; + DirLeft: AX := AX - LinkAhead; + DirDown: AY := AY + LinkAhead; + DirRight: AX := AX + LinkAhead; + end; + end; + if Moved then Player.SetAni('walk', Frame) else Player.SetAni('idle', Frame); + if Moved then CrossEdges; + { links are tested on the player's own walk, at one point: the body's + centre pushed ahead in the walking direction } + if Moved then FollowLink(LinkAt(Player.X + 1.5 + AX, Player.Y + 2 + AY)); + SendMovedProps; + { the lab saw 24 about every 5 s from 5.x; its payload and condition + were not recorded, so the rebuild sends none yet } + FClient.Flush; + if not Headless then Draw; +end; + +{ A colour prop as an index into the 20 colours; a hostile or garbled + value (below 0, above 19) wraps instead of indexing out of the table. } +function ColorIndex(C: Integer): Integer; +begin + Result := ((C mod 20) + 20) mod 20; +end; + +function TAdventure.BodyFor(P: TServerPlayer): TGSurface; +var + Src: TGSurface; + Key: string; + I: Integer; +begin + Result := nil; + Src := Assets.Image(P.BodyImage, 'body'); + if Src = nil then Exit; + if Length(Src.Indices) = 0 then + begin + Result := Src; { not a palette image: drawn as it is } + Exit; + end; + Key := P.BodyImage; + for I := 0 to 4 do Key := Key + ',' + IntToStr(P.Colors[I]); + if P.BodyCache = nil then P.BodyCache := TGSurface.Create(0, 0); + if Key <> P.BodyKey then + begin + P.BodyCache.SetSize(Src.Width, Src.Height); + P.BodyCache.Indices := Src.Indices; + P.BodyCache.Palette := Src.Palette; + { entry 5 skin, 6 coat, 4 sleeves, 3 shoes, 1 belt; 0 the outline (18); + 2 is the clear colour } + P.BodyCache.Recolor([5, 6, 4, 3, 1, 0, 2], + [ColorTable[ColorIndex(P.Colors[0])], ColorTable[ColorIndex(P.Colors[1])], + ColorTable[ColorIndex(P.Colors[2])], ColorTable[ColorIndex(P.Colors[3])], + ColorTable[ColorIndex(P.Colors[4])], ColorTable[18], 0]); + P.BodyKey := Key; + end; + Result := P.BodyCache; +end; + +procedure TAdventure.DrawPlayer(P: TServerPlayer; CamX, CamY: Integer); +var + A: TGraalAni; + St, I, K, BX, BY: Integer; + Parts: TGraalAniPartList; + Spr: TGraalAniSprite; + Img: TGSurface; + SheetName, AttrName: string; +begin + BX := Round((P.X + P.GmapX * BoardW) * TileSize) - CamX; + BY := Round((P.Y + P.GmapY * BoardH) * TileSize) - CamY; + if Gmap = nil then + begin + BX := Round(P.X * TileSize) - CamX; + BY := Round(P.Y * TileSize) - CamY; + end; + A := Assets.Ani(P.AniName); + if A = nil then A := Assets.Ani('idle'); + if A = nil then + begin + { no ganis available: a 32x32 marker where the body is } + Screen.FillRect(BX + 8, BY + 16, 32, 2, $FFFFFFFF); + Screen.FillRect(BX + 8, BY + 46, 32, 2, $FFFFFFFF); + Screen.FillRect(BX + 8, BY + 16, 2, 32, $FFFFFFFF); + Screen.FillRect(BX + 38, BY + 16, 2, 32, $FFFFFFFF); + Exit; + end; + if P.FixedStep >= 0 then + begin + St := P.FixedStep; + if St > High(A.Steps) then St := 0; + end + else + St := A.StepAt(Frame - P.AniStart); + if (St < 0) or (St > High(A.Steps)) then Exit; + Parts := A.Steps[St].Dirs[P.Dir and 3]; + for I := 0 to High(Parts) do + begin + if not A.FindSprite(Parts[I].Sprite, Spr) then Continue; + SheetName := UpperCase(Spr.Sheet); + if SheetName = 'SPRITES' then Img := Assets.Image('sprites.png', '') + else if SheetName = 'HEAD' then Img := Assets.Image(P.HeadImage, 'head') + else if SheetName = 'BODY' then Img := BodyFor(P) + else if SheetName = 'SWORD' then Img := Assets.Image(P.SwordImage, 'sword') + else if SheetName = 'SHIELD' then Img := Assets.Image(P.ShieldImage, 'shield') + else if Copy(SheetName, 1, 4) = 'ATTR' then + begin + K := StrToIntDef(Copy(SheetName, 5, 1), 0); + AttrName := ''; + if (K >= 1) and (K <= 5) then + begin + AttrName := P.Attr[K]; + if AttrName = '' then AttrName := A.DefaultAttr[K]; + end; + Img := Assets.Image(AttrName, 'hat'); + end + else + Img := Assets.Image(Spr.Sheet, ''); + if Img <> nil then + Screen.Blit(Img, Spr.X, Spr.Y, Spr.W, Spr.H, BX + Parts[I].X, BY + Parts[I].Y); + end; +end; + +{ GS1's addtiledef IMAGE,PREFIX[,TYPE] swaps the tile sheet for every level + whose name starts with PREFIX (2.22's offline tutorial sets picso.png + for "offlinetutorial" this way). Without a script engine the rebuild + reads the line wherever it is in a level's NPCs, without its condition. } +procedure TAdventure.NoteTileDefs(L: TAdventureLevel); +var + I, P, E: Integer; + Src, Low, Args, Img, Prefix: string; + Parts: TStringList; +begin + Parts := TStringList.Create; + try + for I := 0 to High(L.NPCs) do + begin + Src := L.NPCs[I].Script; + Low := LowerCase(Src); + P := Pos('addtiledef ', Low); + while P > 0 do + begin + E := P + Length('addtiledef '); + Args := ''; + while (E <= Length(Src)) and not (Src[E] in [';', #10, #13, '}']) do + begin + Args := Args + Src[E]; + Inc(E); + end; + Parts.CommaText := ''; + Parts.Delimiter := ','; + Parts.StrictDelimiter := True; + Parts.DelimitedText := Args; + if Parts.Count >= 2 then + begin + Img := Trim(Parts[0]); + Prefix := LowerCase(Trim(Parts[1])); + if (Img <> '') and (Pos('#', Img) = 0) and (Pos('..', Img) = 0) then + begin + if FTileDefs.IndexOf(Prefix + #9 + Img) >= 0 then + FTileDefs.Delete(FTileDefs.IndexOf(Prefix + #9 + Img)); + FTileDefs.Insert(0, Prefix + #9 + Img); + end; + end; + Delete(Low, 1, E - 1); + Delete(Src, 1, E - 1); + P := Pos('addtiledef ', Low); + end; + end; + finally + Parts.Free; + end; +end; + +function TAdventure.TileSheetFor(const LevelName: string): TGSurface; +var + I, T: Integer; + N, Prefix: string; + S: TGSurface; +begin + Result := Sheet; + N := LowerCase(LevelName); + for I := 0 to FTileDefs.Count - 1 do + begin + T := Pos(#9, FTileDefs[I]); + Prefix := Copy(FTileDefs[I], 1, T - 1); + if Copy(N, 1, Length(Prefix)) = Prefix then + begin + S := Assets.Image(Copy(FTileDefs[I], T + 1, MaxInt), ''); + if (S <> nil) and (S.Width > 0) then Result := S; + Exit; + end; + end; +end; + +procedure TAdventure.Draw; +var + CamX, CamY, TX, TY, X0, Y0, I, T, WorldW, WorldH, PX, PY: Integer; + Tiles: TGSurface; +begin + Screen.Fill($FF000000); + if Sheet.Width = 0 then MakeIndexSheet(Sheet); + if Level.Name <> FTileDefLevel then + begin + NoteTileDefs(Level); + FTileDefLevel := Level.Name; + end; + Tiles := TileSheetFor(Level.Name); + { on a gmap the camera works in world tiles: local + 64 x cell } + PX := 0; + PY := 0; + WorldW := BoardW; + WorldH := BoardH; + if Gmap <> nil then + begin + PX := Player.GmapX * BoardW; + PY := Player.GmapY * BoardH; + WorldW := Gmap.Width * BoardW; + WorldH := Gmap.Height * BoardH; + end; + { centre on the player's body (the sprite box is 3 tiles wide) } + CamX := Round((Player.X + PX + 1.5) * TileSize) - ScreenW div 2; + CamY := Round((Player.Y + PY + 2) * TileSize) - ScreenH div 2; + if CamX > WorldW * TileSize - ScreenW then CamX := WorldW * TileSize - ScreenW; + if CamY > WorldH * TileSize - ScreenH then CamY := WorldH * TileSize - ScreenH; + if CamX < 0 then CamX := 0; + if CamY < 0 then CamY := 0; + X0 := CamX div TileSize; + Y0 := CamY div TileSize; + for TY := Y0 to Y0 + ScreenH div TileSize + 1 do + for TX := X0 to X0 + ScreenW div TileSize + 1 do + if (TX < WorldW) and (TY < WorldH) then + begin + T := WorldTile(TX, TY); + if T >= 0 then + DrawTile(Screen, Tiles, T, TX * TileSize - CamX, TY * TileSize - CamY); + end; + { others first, then the player on top; none in Login mode } + if LoginMode then Exit; + for I := 0 to FOthers.Count - 1 do + DrawPlayer(Others[I], CamX, CamY); + DrawPlayer(Player, CamX, CamY); +end; + +end. diff --git a/graal-5.00r7-G3D22067/src/Graal500.dpr b/graal-5.00r7-G3D22067/src/Graal500.dpr new file mode 100644 index 0000000..db1484c --- /dev/null +++ b/graal-5.00r7-G3D22067/src/Graal500.dpr @@ -0,0 +1,604 @@ +{ Graal 5.00r7 (G3D22067), rebuilt. The original is a Delphi launcher over + a C++ engine library for Windows; this rebuild carries the 3.153 one + over, since 5.00r7 keeps the gen-5 wire (graal_analysis + protocol/v5x-clients.md). + + Command line: + Graal500 --server HOST:PORT --account NAME [--password-env VAR] + [--server-name NAME] + Graal500 --level FILE.graal|FILE.nw|FILE.gmap [--x X --y Y] + --server-name: what the client calls that server (default Login, as + 5.00r7 calls the first server it reaches: no characters are drawn until + a server warp (178) names another). + common options: + --data DIR a Graal install: pics1, arrays.dat, levels/ganis, heads, + bodies, swords, shields, hats + --window show the game in a window and read the keyboard + (arrows or IJKL walk, Esc quits) + --headless no drawing at all (stress runs) + --frames N stop after N frames; 0 = until stopped (default: 100 + without a window or --seconds, no limit in a window) + --seconds N stop after N seconds + --keys SCRIPT scripted keys, e.g. "right*10,down*4,wait*5"; each + entry holds one direction for that many frames + --walk MODE script (default with --keys), idle (default without), + or random + --walk-ms N random walk: a new direction every N ms (default 100) + --seed N random walk seed + --link-every N random walk: every N seconds head for the nearest link + --nodelay set TCP_NODELAY (5.00r7's setting is not traced) + --stats-every N a JSON stats line on stdout every N seconds + --dump FRAME.bmp write the last frame + --sheet FILE a tile sheet other than the install's pics1 + + Log lines go to stderr as they happen. Online, one JSON summary line goes + to stdout at the end. SIGTERM / SIGINT (Ctrl+Break / Ctrl+C on Windows) + end the run cleanly. + + Exit codes, online: 0 logged in and ended cleanly, 1 error, 2 never + logged in, 3 the link dropped after login. Offline: 0 the level parsed, + 1 it did not. 64: bad command line. } +program Graal500; + +{$IFDEF FPC}{$MODE DELPHI}{$H+}{$ENDIF} +{ A windowed program on Windows, like 2.05: started with no arguments it + opens the start screen. With arguments it attaches to the console it was + started from (OpenConsoleIO) and runs as before. } +{$IFDEF MSWINDOWS}{$IFDEF FPC}{$APPTYPE GUI}{$ELSE}{$APPTYPE CONSOLE}{$ENDIF}{$ENDIF} + +uses + SysUtils, Classes, + GTypes in '../../common/GTypes.pas', + GZlib in '../../common/GZlib.pas', + GSocket in '../../common/GSocket.pas', + GLevel in '../../common/GLevel.pas', + GSurface in '../../common/GSurface.pas', + GArrays in '../../common/GArrays.pas', + GBzip2 in '../../common/GBzip2.pas', + GBuiltin in '../../common/GBuiltin.pas', + GAssetDirs in '../../common/GAssetDirs.pas', + GAni in '../../common/GAni.pas', + GFont in '../../common/GFont.pas', + GWindow in '../../common/GWindow.pas', + Protocol500 in 'Protocol500.pas', + GraalClient in 'GraalClient.pas', + Adventure in 'Adventure.pas', + GStartScreen in '../../common/GStartScreen.pas', + ListServer500 in 'ListServer500.pas', + StartScreen500 in 'StartScreen500.pas', + RunMode in 'RunMode.pas'; + +var + { Set while the start screen runs a game: the arguments it chose, read + in place of the command line. } + GuiArgs: TStringList = nil; + { why the last game ended, for the start screen } + LastGameError: string = ''; + +function ArgCount: Integer; +begin + if GuiArgs <> nil then Result := GuiArgs.Count else Result := ParamCount; +end; + +function ArgAt(I: Integer): string; +begin + if GuiArgs <> nil then Result := GuiArgs[I - 1] else Result := ParamStr(I); +end; + +function Arg(const Name, Default: string): string; +var + I: Integer; +begin + Result := Default; + for I := 1 to ArgCount - 1 do + if ArgAt(I) = Name then + begin + Result := ArgAt(I + 1); + Exit; + end; +end; + +function HasArg(const Name: string): Boolean; +var + I: Integer; +begin + Result := False; + for I := 1 to ArgCount do + if ArgAt(I) = Name then Result := True; +end; + + +procedure Usage; +begin + WriteLn('Graal ', ClientBuildLabel, ' (', ClientVersionToken, ') rebuild'); + WriteLn(' (no arguments: the start screen, Training or the server list)'); + WriteLn(' --server HOST:PORT --account NAME [--password-env VAR] [--server-name NAME]'); + WriteLn(' --level FILE [--x X --y Y]'); + WriteLn(' common: [--data DIR] [--window | --headless] [--frames N] [--seconds N]'); + WriteLn(' [--keys SCRIPT] [--walk script|idle|random] [--walk-ms N] [--seed N]'); + WriteLn(' [--link-every N] [--nodelay] [--stats-every N]'); + WriteLn(' [--dump FRAME.bmp] [--sheet FILE]'); +end; + +type + TKeyScript = class + public + Dirs: array of Integer; { -1 = no key } + procedure Parse(const S: string); + function DirAt(Frame: Integer): Integer; + end; + +procedure TKeyScript.Parse(const S: string); +var + Items: TStringList; + I, J, N, D, Star: Integer; + Name: string; +begin + Items := TStringList.Create; + try + Items.CommaText := S; + for I := 0 to Items.Count - 1 do + begin + Star := Pos('*', Items[I]); + if Star > 0 then + begin + Name := LowerCase(Copy(Items[I], 1, Star - 1)); + N := StrToIntDef(Copy(Items[I], Star + 1, MaxInt), 1); + end + else + begin + Name := LowerCase(Items[I]); + N := 1; + end; + if Name = 'up' then D := DirUp + else if Name = 'left' then D := DirLeft + else if Name = 'down' then D := DirDown + else if Name = 'right' then D := DirRight + else D := -1; + for J := 1 to N do + begin + SetLength(Dirs, Length(Dirs) + 1); + Dirs[High(Dirs)] := D; + end; + end; + finally + Items.Free; + end; +end; + +function TKeyScript.DirAt(Frame: Integer): Integer; +begin + if (Frame >= 0) and (Frame <= High(Dirs)) then Result := Dirs[Frame] + else Result := -1; +end; + +{ The middle and largest of the first N warp times. } +procedure WarpStats(G: TAdventure; out P50, Max: Integer); +var + A: array of Integer; + I, J, T: Integer; +begin + P50 := 0; + Max := 0; + if G.WarpCount = 0 then Exit; + SetLength(A, G.WarpCount); + for I := 0 to G.WarpCount - 1 do A[I] := G.WarpTimes[I]; + for I := 1 to High(A) do + begin + T := A[I]; + J := I - 1; + while (J >= 0) and (A[J] > T) do + begin + A[J + 1] := A[J]; + Dec(J); + end; + A[J + 1] := T; + end; + P50 := A[High(A) div 2]; + Max := A[High(A)]; +end; + +function StatsJson(const Kind, EndState, Error, Account: string; G: TAdventure; + H: TTickHistogram; Ticks: Integer; RunUs: Int64; NoDelay: Boolean): string; +var + WP50, WMax: Integer; + Login: string; +begin + WarpStats(G, WP50, WMax); + if G.LoginMs >= 0 then Login := IntToStr(G.LoginMs) else Login := 'null'; + Result := '{"kind":' + JsonStr(Kind) + + ',"version":' + JsonStr(ClientBuildLabel) + + ',"token":' + JsonStr(ClientVersionToken) + + ',"account":' + JsonStr(Account); + if EndState <> '' then + Result := Result + ',"end":' + JsonStr(EndState) + ',"error":' + JsonStr(Error); + Result := Result + + ',"login_ms":' + Login + + ',"run_s":' + JsonMs(RunUs / 1000000.0) + + ',"ticks":' + IntToStr(Ticks) + + ',"frames_in":' + IntToStr(G.Client.FramesIn) + + ',"frames_out":' + IntToStr(G.Client.FramesOut) + + ',"msgs_in":' + IntToStr(G.Client.MessagesIn) + + ',"msgs_out":' + IntToStr(G.Client.MessagesOut) + + ',"bytes_in":' + IntToStr(G.Client.BytesIn) + + ',"bytes_out":' + IntToStr(G.Client.BytesOut) + + ',"warps":' + IntToStr(G.WarpsSent) + + ',"warps_done":' + IntToStr(G.WarpCount) + + ',"warp_ms_p50":' + IntToStr(WP50) + + ',"warp_ms_max":' + IntToStr(WMax) + + ',"tick_ms_p50":' + JsonMs(H.QuantileMs(0.5)) + + ',"tick_ms_p99":' + JsonMs(H.QuantileMs(0.99)) + + ',"tick_ms_max":' + JsonMs(H.MaxMs) + + ',"rss_peak_kib":'; + if PeakRssKiB >= 0 then Result := Result + IntToStr(PeakRssKiB) + else Result := Result + 'null'; + Result := Result + ',"nodelay":' + LowerCase(BoolToStr(NoDelay, True)) + '}'; +end; + +{ One game: from the command line, or as the start screen chose it (then + GuiWin is the window to play in, and nothing goes to stdout). Returns + the exit code. } +function RunGame(GuiWin: TGWindow; const GuiPw, GuiNick: string): Integer; +var + G: TAdventure; + Win: TGWindow; + Script: TKeyScript; + Walker: TWalker; + Hist: TTickHistogram; + Server, Host, Sheet, Dump, Pw, Data, Account, WalkName, EndState, Error: string; + Port, Frames, I, C, D, Seconds, StatsEvery, ExitCode_: Integer; + OK, Online, UseWindow, NoDelay, Dropped, Crashed: Boolean; + StartUs, GateUs, NowUs, T0, NextStatsUs: Int64; + +begin + Result := 64; + ExitCode_ := 64; + Server := Arg('--server', ''); + if (Server = '') and (Arg('--level', '') = '') then + begin + Usage; + Exit; + end; + Online := Server <> ''; + UseWindow := HasArg('--window') and not HasArg('--headless'); + NoDelay := HasArg('--nodelay'); + Account := Arg('--account', ''); + InstallStopHandlers; + G := TAdventure.Create; + G.ServerName := Arg('--server-name', FirstServerName); + G.Echo := GuiWin = nil; + G.Headless := HasArg('--headless'); + if GuiNick <> '' then G.Player.Nickname := GuiNick; + Win := GuiWin; + Script := TKeyScript.Create; + Walker := TWalker.Create(Cardinal(StrToIntDef(Arg('--seed', '1'), 1))); + Hist := TTickHistogram.Create; + Dropped := False; + Crashed := False; + Error := ''; + I := 0; + StartUs := MonoUs; + try + Sheet := Arg('--sheet', ''); + if Sheet <> '' then + if LoadImageFile(Sheet, G.Sheet) then + G.SheetBuiltin := False + else + G.Log('warning: cannot load tile sheet ' + Sheet + '; using the built-in one'); + Data := Arg('--data', ''); + { no --data: the program's folder (and a graal-assets beside it) } + if Data = '' then Data := ExtractFilePath(ParamStr(0)); + G.UseInstall(Data); + Script.Parse(Arg('--keys', '')); + if Arg('--keys', '') <> '' then WalkName := Arg('--walk', 'script') + else WalkName := Arg('--walk', 'idle'); + WalkName := LowerCase(WalkName); + if WalkName = 'random' then Walker.Mode := wmRandom + else if WalkName = 'idle' then Walker.Mode := wmIdle + else Walker.Mode := wmScript; + Walker.WalkTicks := StrToIntDef(Arg('--walk-ms', '100'), 100) div TickMs; + if Walker.WalkTicks < 1 then Walker.WalkTicks := 1; + Walker.LinkEveryTicks := StrToIntDef(Arg('--link-every', '0'), 0) * 1000 div TickMs; + Dump := Arg('--dump', ''); + Seconds := StrToIntDef(Arg('--seconds', '0'), 0); + StatsEvery := StrToIntDef(Arg('--stats-every', '0'), 0); + if HasArg('--frames') then Frames := StrToIntDef(Arg('--frames', '0'), 0) + else if UseWindow or (Seconds > 0) then Frames := 0 + else Frames := 100; + OK := False; + + if Online then + begin + C := Pos(':', Server); + if C > 0 then + begin + Host := Copy(Server, 1, C - 1); + Port := StrToIntDef(Copy(Server, C + 1, MaxInt), 14802); + end + else + begin + Host := Server; + Port := 14802; + end; + if GuiWin <> nil then Pw := GuiPw + else Pw := SysUtils.GetEnvironmentVariable(Arg('--password-env', 'GRAAL_PW')); + if G.ConnectServer(Host, Port, Account, Pw) then + begin + if NoDelay and not G.Client.Socket.SetNoDelay(True) then + G.Log('warning: TCP_NODELAY could not be set'); + end + else + begin + Error := G.Client.LastError; + Frames := -1; + end; + end + else + begin + OK := G.LoadLevelFile(Arg('--level', '')); + if OK then + begin + G.Player.X := StrToFloatDef(Arg('--x', '30'), 30); + G.Player.Y := StrToFloatDef(Arg('--y', '30'), 30); + G.Log(Format('%s: %s, %d links, %d signs, %d chests, %d npcs, %d baddies', + [G.Level.Name, G.Level.Magic, Length(G.Level.Links), Length(G.Level.Signs), + Length(G.Level.Chests), Length(G.Level.NPCs), Length(G.Level.Baddies)])); + end + else + begin + G.Log('level failed: ' + G.Level.LastError); + Frames := -1; + end; + end; + + if UseWindow and (Frames >= 0) and (Win = nil) then + begin + Win := TGWindow.Create('Graal ' + ClientBuildLabel + ' (' + ClientVersionToken + ')', + ScreenW, ScreenH); + if not Win.Ok then + begin + G.Log('no display: running without a window'); + FreeAndNil(Win); + end; + end; + + { the frame loop: a 50 ms gate; a late frame is not made up } + StartUs := MonoUs; + GateUs := StartUs; + NextStatsUs := StartUs + Int64(StatsEvery) * 1000000; + try + while Frames >= 0 do + begin + if StopRequested then + begin + G.Log('stop requested'); + Break; + end; + if (Frames > 0) and (I >= Frames) then Break; + if (Seconds > 0) and (MonoUs - StartUs >= Int64(Seconds) * 1000000) then Break; + for D := 0 to 3 do G.Keys[D] := False; + if Win <> nil then + begin + Win.Pump; + if Win.Closed or Win.Held[gkEscape] then Break; + G.Keys[DirUp] := Win.Held[gkUp]; + G.Keys[DirLeft] := Win.Held[gkLeft]; + G.Keys[DirDown] := Win.Held[gkDown]; + G.Keys[DirRight] := Win.Held[gkRight]; + end; + if Walker.Mode = wmScript then D := Script.DirAt(I) + else D := Walker.DirAt(I, G.Level, G.Player.X, G.Player.Y); + if D >= 0 then G.Keys[D] := True; + T0 := MonoUs; + G.Tick; + Hist.Add(MonoUs - T0); + if Win <> nil then Win.Present(G.Screen); + Inc(I); + if Online and not G.Client.Connected then + begin + Dropped := True; + Error := G.Client.LastError; + if Error = '' then Error := G.DisconnectReason; + Break; + end; + NowUs := MonoUs; + if (StatsEvery > 0) and (NowUs >= NextStatsUs) and (GuiWin = nil) then + begin + WriteLn(StatsJson('stats', '', '', Account, G, Hist, I, NowUs - StartUs, NoDelay)); + Flush(Output); + Inc(NextStatsUs, Int64(StatsEvery) * 1000000); + end; + Inc(GateUs, TickMs * 1000); + if GateUs > NowUs then + Sleep((GateUs - NowUs) div 1000) + else if NowUs - GateUs > 1000000 then + GateUs := NowUs; { a stall is one frame } + end; + except + on E: Exception do + begin + Crashed := True; + Error := E.ClassName + ': ' + E.Message; + G.Log('error: ' + Error); + end; + end; + + if Online then + begin + { a clean logout: what is queued goes out, then the link closes } + G.Client.Flush; + G.Client.Disconnect; + OK := G.LoggedIn and G.BoardLoaded; + G.Log(Format('frames in %d (%d msgs), out %d (%d msgs); logged in %s, board %s', + [G.Client.FramesIn, G.Client.MessagesIn, G.Client.FramesOut, + G.Client.MessagesOut, BoolToStr(G.LoggedIn, True), + BoolToStr(G.BoardLoaded, True)])); + end; + if (Dump <> '') or ((I = 0) and not Online) then + G.Draw; + G.Log(Format('player at %.2f,%.2f facing %d', [G.Player.X, G.Player.Y, G.Player.Dir])); + for C := 0 to G.OtherCount - 1 do + G.Log(Format('other player %d %s at %.1f,%.1f sprite %d', [G.Others[C].Id, + G.Others[C].Nickname, G.Others[C].X, G.Others[C].Y, G.Others[C].Sprite])); + if G.Assets.Missing.Count > 0 then + G.Log('not found in the install: ' + G.Assets.Missing.CommaText); + if Dump <> '' then + begin + G.Screen.SaveBMP(Dump); + G.Log('frame written to ' + Dump); + end; + + if Online then + begin + if Crashed then begin EndState := 'error'; ExitCode_ := 1; end + else if not OK then begin EndState := 'nologin'; ExitCode_ := 2; end + else if Dropped then begin EndState := 'dropped'; ExitCode_ := 3; end + else begin EndState := 'clean'; ExitCode_ := 0; end; + if GuiWin = nil then + WriteLn(StatsJson('summary', EndState, Error, Account, G, Hist, I, + MonoUs - StartUs, NoDelay)); + if Error <> '' then LastGameError := Error + else if not OK then LastGameError := 'the server did not log you in' + else LastGameError := ''; + end + else if OK and not Crashed then ExitCode_ := 0 + else ExitCode_ := 1; + finally + if Win <> GuiWin then Win.Free; + Script.Free; + Walker.Free; + Hist.Free; + G.Free; + end; + Result := ExitCode_; +end; + +{ Training. Whether 5.00r7 has offline play at all is not traced (its + start goes to the Login server). The rebuild keeps 3.153's Training: + the offline tutorial levels (offlinetutorial_b-2 at 30, 30) when they lie + in the install, else the built-in starter level (a start.nw next to the + program replaces it), so a level can be walked without a server. } +procedure TrainingLevel(const Dir: string; out Path, X, Y: string); +begin + X := '30'; + Y := '30'; + Path := FirstFileIn(Dir, 'levels/offlinetutorial_b-2.nw;levels/offlinetutorial_b-2.graal;offlinetutorial_b-2.nw;offlinetutorial_b-2.graal'); + if Path = '' then + begin + Path := Dir + 'start.nw'; + X := '30'; + Y := '30'; + end; +end; + +{ No arguments: the start screen, then the game it picks, and back to the + start screen when the game ends (Esc, or a failed or dropped login). } +function RunGui: Integer; +var + Win: TGWindow; + G: TAdventure; + R: TStartResult; + Dir, ListHost, ArrHost, Msg, Lvl, X, Y: string; + ListPort: Integer; + Picked: Boolean; + Fetch: TListFetch500; + Info: TStartInfo; + Who: TCharacter500; + PickedName: string; + I: Integer; +begin + Result := 0; + Dir := ExtractFilePath(ParamStr(0)); + Win := TGWindow.Create('Graal ' + ClientBuildLabel + ' (' + ClientVersionToken + ')', + ScreenW, ScreenH); + try + if not Win.Ok then + begin + OpenConsoleIO; + WriteLn(ErrOutput, 'no display for the start screen; run with arguments:'); + Usage; + Result := 64; + Exit; + end; + { 5.00r7 has no listserver; the rebuild's list comes from + listserver.txt next to the program, or listserver.graal.in:14922 } + { SIGTERM / Ctrl+C end the program on the start screen too } + InstallStopHandlers; + SetAssetRoots(Dir, ClientBuildLabel); + ReadListServer(Dir, DefaultListHost, DefaultListPort, ListHost, ListPort); + FillChar(R, SizeOf(R), 0); + Msg := ''; + repeat + Win.TakeChars; + G := TAdventure.Create; + Fetch := TListFetch500.Create; + Who := TCharacter500.Create; + try + G.UseInstall(Dir); + Who.G := G; + Info.Title := 'graal-delphi'; + Info.Subtitle := '5.00r7 rebuilt'; + Info.DrawCharacter := Who.Draw; + Info.StopRequested := StopRequested; + Picked := RunStartScreen(Win, G.Screen, Fetch, Info, Dir, ListHost, ListPort, Msg, R); + { the picked server's name, as if the Login server had warped + there; a server not on the list is the Login server } + PickedName := FirstServerName; + if Picked and (R.Choice = scOnline) then + for I := 0 to High(Fetch.Servers) do + if (Fetch.Servers[I].Host = R.Host) and (Fetch.Servers[I].Port = R.Port) then + begin + PickedName := ServerDisplayName(Fetch.Servers[I].Name); + Break; + end; + finally + Who.Free; + Fetch.Free; + G.Free; + end; + if not Picked or Win.Closed or StopRequested then Exit; + GuiArgs := TStringList.Create; + try + GuiArgs.Add('--window'); + GuiArgs.Add('--data'); + GuiArgs.Add(Dir); + if R.Choice = scTraining then + begin + TrainingLevel(Dir, Lvl, X, Y); + GuiArgs.Add('--level'); + GuiArgs.Add(Lvl); + GuiArgs.Add('--x'); + GuiArgs.Add(X); + GuiArgs.Add('--y'); + GuiArgs.Add(Y); + end + else + begin + GuiArgs.Add('--server'); + GuiArgs.Add(R.Host + ':' + IntToStr(R.Port)); + GuiArgs.Add('--account'); + GuiArgs.Add(R.Account); + GuiArgs.Add('--server-name'); + GuiArgs.Add(PickedName); + end; + LastGameError := ''; + if RunGame(Win, R.Password, R.Nickname) <> 0 then + Msg := LastGameError + else + Msg := ''; + finally + FreeAndNil(GuiArgs); + end; + until Win.Closed or StopRequested; + finally + Win.Free; + end; +end; + +begin + Randomize; + if ParamCount = 0 then + Halt(RunGui); + OpenConsoleIO; + Halt(RunGame(nil, '', '')); +end. diff --git a/graal-5.00r7-G3D22067/src/GraalClient.pas b/graal-5.00r7-G3D22067/src/GraalClient.pas new file mode 100644 index 0000000..9572d57 --- /dev/null +++ b/graal-5.00r7-G3D22067/src/GraalClient.pas @@ -0,0 +1,508 @@ +{ GraalClient: TGraalClient and TAdventureClient, the 5.00r7 game link. + 5.00r7's network code sits in a C++ engine library, not in Delphi, but + on the wire it keeps the gen-5 codec of 2.22 to 4.20 (graal_analysis + protocol/v5x-clients.md, "Cipher"): the same framing and compression + thresholds, so the rebuild keeps the 2.22 class split. What 5.00r7 does + at login (v5x-clients.md, "Login"; version-profiles/lab-v5-2026-10-30.md): + the login line alone in the plain zlib frame, ending with the comma list + "win" and three machine fields, then 37 (language) in its own gen-5 + frame. No tamper check follows, ever. + The notes below are the 2.22 ones, which hold for 5.00r7 too. + + Same class split as 2.05 (graal_analysis client-internals/ + client-architecture-205.md; client-versions.md: "all four clients are + Delphi builds with the same network classes"): + TGraalClient socket, out buffer, u16be frames, receive split + TAdventureClient the gen-5 frame codec, the login line builder + + What changed from 2.05 (protocol/codec-and-framing.md, "Gen 4/5 partial + XOR", and protocol/client-versions.md, "Gen-5 send on the client"): + - Messages are no longer touched one by one; the whole frame body is. + - Login: type 5, the key, GNW03014, account, password. That one frame + is u16be + zlib with no compression byte and no XOR, so the key can + be read. It is flushed by itself, then the socket switches to gen 5. + - Every later frame, both ways: u16be (body length + 1), a compression + byte, the body. The client picks 2 (raw) under 0x30 bytes unless zlib + is shorter, 4 (zlib) from 0x30, 6 (bz2) from 0x1000. Even codes are + XORed: one LCG step per 4-byte group present, at most 12 groups raw or + 4 compressed; a short last group still steps. Each direction has its + own iterator, seeded 0x04A80B38, with the same key. + Receive: u16be -> undo XOR -> inflate / bunzip -> split on #10, with the + PLO_RAWDATA escape, as in 2.05. } +unit GraalClient; + +{$IFDEF FPC}{$MODE DELPHI}{$H+}{$ENDIF} + +interface + +uses + GSocket; + +type + TMessageEvent = procedure(Id: Integer; const Data: string) of object; + TLogEvent = procedure(const Line: string) of object; + + TGraalClient = class + protected + FSocket: TGSocket; + FOut: string; { pending, uncompressed messages } + FInRaw: string; { bytes from the socket, not yet a whole frame } + FInPlain: string; { decoded stream, not yet whole messages } + FRawPending: Integer; { > 0: the next n bytes are one message } + FOnMessage: TMessageEvent; + FOnLog: TLogEvent; + FFramesIn, FFramesOut, FMessagesIn, FMessagesOut: Integer; + FBytesIn, FBytesOut: Int64; + procedure Log(const S: string); + { Hooks for the frame codec; the base class is plain zlib both ways. } + function EncodeFrame(const Plain: string): string; virtual; + function DecodeFrame(const Body: string; out Plain: string): Boolean; virtual; + procedure SplitMessages; + procedure DeliverMessage(const Msg: string); + { Logs Why, drops the link and the receive buffers. } + procedure Fail(const Why: string); + public + LastError: string; + { Tests: with Sink set, the client counts as connected and Flush + appends each frame (length included) to Sent instead of a socket. } + Sink: Boolean; + Sent: string; + constructor Create; + destructor Destroy; override; + function Connect(const Host: string; Port: Word): Boolean; virtual; + procedure Disconnect; + function Connected: Boolean; + { Queues one message. Returns False if Data holds #10 (dropped). } + function SendPacket(Id: Integer; const Data: string): Boolean; virtual; + procedure Flush; + { Called from the tick: read the socket, unpack frames, dispatch. } + procedure Poll; + { Takes bytes as if they came from the socket: frames, then messages. + Poll uses it; tests and the fuzzer call it directly. } + procedure FeedRaw(const Bytes: string); + property OnMessage: TMessageEvent read FOnMessage write FOnMessage; + property OnLog: TLogEvent read FOnLog write FOnLog; + property FramesIn: Integer read FFramesIn; + property FramesOut: Integer read FFramesOut; + property MessagesIn: Integer read FMessagesIn; + property MessagesOut: Integer read FMessagesOut; + { bytes on the wire, frame headers included } + property BytesIn: Int64 read FBytesIn; + property BytesOut: Int64 read FBytesOut; + property Socket: TGSocket read FSocket; + end; + + { One direction of the gen-5 codec. } + TGen5 = class + public + Key: Byte; + Iterator: Cardinal; + constructor Create(AKey: Byte); + { XORs Body in place for compression type CType (even codes only). } + procedure Apply(var Body: string; CType: Integer); + end; + + TAdventureClient = class(TGraalClient) + protected + FKey: Byte; + FLoginFrame: Boolean; { the next flush is the fixed login frame } + FOutCodec, FInCodec: TGen5; + function EncodeFrame(const Plain: string): string; override; + function DecodeFrame(const Body: string; out Plain: string): Boolean; override; + procedure ResetCodec; + public + destructor Destroy; override; + function Connect(const Host: string; Port: Word): Boolean; override; + { The login as 5.00r7 sends it: the login line alone in the fixed + plain zlib frame (flushed here), then 37 with the language, queued + for the caller's flush, so it goes in the first gen-5 frame. } + procedure SendLogin(const Account, Password, Language: string); + { Sets up the codec state without a socket (tests, the fuzzer). } + procedure StartOffline(AKey: Byte); + procedure SendToAll(const Text: string); + property Key: Byte read FKey write FKey; + property OutCodec: TGen5 read FOutCodec; + property InCodec: TGen5 read FInCodec; + end; + +{ The tail of the login line after the password: the platform, then the + machine fields, comma-separated with no length prefix. } +function LoginTail: string; + +{ The compression byte 5.00r7 (as 2.22) picks for an out buffer, and the body. } +function PackBody(const Plain: string; out CType: Integer): string; + +implementation + +uses + SysUtils, GTypes, GZlib, GBzip2, Protocol500; + +{ TGen5 } + +constructor TGen5.Create(AKey: Byte); +begin + inherited Create; + Key := AKey; + Iterator := CipherSeed; +end; + +{ the iterator wraps at 32 bits on purpose } +{$IFOPT Q+}{$DEFINE OVERFLOW_WAS_ON}{$Q-}{$ENDIF} +{$IFOPT R+}{$DEFINE RANGE_WAS_ON}{$R-}{$ENDIF} +procedure TGen5.Apply(var Body: string; CType: Integer); +var + Groups, G, J, P: Integer; + K: Cardinal; +begin + if (CType and 1) <> 0 then Exit; { odd codes are not XORed } + if CType = CompressNone then Groups := XorGroupsRaw + else Groups := XorGroupsPacked; + if (Length(Body) + 3) div 4 < Groups then Groups := (Length(Body) + 3) div 4; + UniqueString(Body); + for G := 0 to Groups - 1 do + begin + Iterator := Iterator * CipherMul + Key; + K := Iterator; + for J := 0 to 3 do + begin + P := G * 4 + J + 1; + if P > Length(Body) then Break; + Body[P] := Chr(Ord(Body[P]) xor ((K shr (8 * J)) and $FF)); + end; + end; +end; +{$IFDEF RANGE_WAS_ON}{$R+}{$ENDIF} +{$IFDEF OVERFLOW_WAS_ON}{$Q+}{$ENDIF} + +function PackBody(const Plain: string; out CType: Integer): string; +var + Z: string; +begin + if Length(Plain) >= Bz2From then + begin + CType := CompressBz2; + Result := BZ2Compress(Plain); + end + else if Length(Plain) >= ZlibFrom then + begin + CType := CompressZlib; + Result := ZCompress(Plain); + end + else + begin + Z := ZCompress(Plain); + if Length(Z) < Length(Plain) then + begin + CType := CompressZlib; + Result := Z; + end + else + begin + CType := CompressNone; + Result := Plain; + end; + end; +end; + +{ TGraalClient } + +constructor TGraalClient.Create; +begin + inherited Create; + FSocket := TGSocket.Create; +end; + +destructor TGraalClient.Destroy; +begin + FSocket.Free; + inherited Destroy; +end; + +procedure TGraalClient.Log(const S: string); +begin + if Assigned(FOnLog) then FOnLog(S); +end; + +function TGraalClient.Connect(const Host: string; Port: Word): Boolean; +begin + FOut := ''; + FInRaw := ''; + FInPlain := ''; + FRawPending := 0; + Result := FSocket.Connect(Host, Port); + if not Result then LastError := FSocket.LastError; +end; + +procedure TGraalClient.Disconnect; +begin + FSocket.Close; + Sink := False; +end; + +function TGraalClient.Connected: Boolean; +begin + Result := FSocket.Connected or Sink; +end; + +function TGraalClient.EncodeFrame(const Plain: string): string; +begin + Result := ZCompress(Plain); +end; + +function TGraalClient.DecodeFrame(const Body: string; out Plain: string): Boolean; +begin + Result := ZDecompress(Body, Plain); +end; + +function TGraalClient.SendPacket(Id: Integer; const Data: string): Boolean; +var + Msg: string; +begin + Result := False; + if Pos(#10, Data) > 0 then Exit; { silently dropped } + Msg := GChar(Id) + Data + #10; + if (FOut <> '') and (Length(FOut) + Length(Msg) > OutFlushAt) then + Flush; + FOut := FOut + Msg; + Inc(FMessagesOut); + if Length(FOut) > OutDropAt then + begin + LastError := 'more than 256 KB queued'; + Disconnect; + Exit; + end; + Result := True; +end; + +procedure TGraalClient.Flush; +var + Z: string; +begin + if (FOut = '') or not Connected then Exit; + Z := EncodeFrame(FOut); + FOut := ''; + if Length(Z) > $FFFF then + begin + LastError := 'frame too long for its u16 length'; + Disconnect; + Exit; + end; + if Sink then + Sent := Sent + Chr((Length(Z) shr 8) and $FF) + Chr(Length(Z) and $FF) + Z + else + FSocket.Send(Chr((Length(Z) shr 8) and $FF) + Chr(Length(Z) and $FF) + Z); + Inc(FFramesOut); + Inc(FBytesOut, Length(Z) + 2); +end; + +procedure TGraalClient.Poll; +var + Got: string; +begin + if not FSocket.Connected then Exit; + Got := ''; + if not FSocket.Poll(Got) then + LastError := FSocket.LastError; + if Got <> '' then + begin + Inc(FBytesIn, Length(Got)); + FeedRaw(Got); + end; +end; + +procedure TGraalClient.FeedRaw(const Bytes: string); +var + P, Len: Integer; + Body: string; +begin + FInRaw := FInRaw + Bytes; + { frames are read by position and the used bytes dropped once, so a burst + of many frames is linear, not quadratic } + P := 1; + while Length(FInRaw) - P + 1 >= 2 do + begin + Len := (Ord(FInRaw[P]) shl 8) or Ord(FInRaw[P + 1]); + if Length(FInRaw) - P + 1 < Len + 2 then Break; + if not DecodeFrame(Copy(FInRaw, P + 2, Len), Body) then + begin + Fail('bad frame from the server'); + Exit; + end; + if Length(Body) > InFrameMax then + begin + Fail('frame from the server inflates past the limit'); + Exit; + end; + Inc(P, Len + 2); + Inc(FFramesIn); + FInPlain := FInPlain + Body; + SplitMessages; + if FInRaw = '' then Exit; { Fail cleared the buffers } + end; + if P > 1 then Delete(FInRaw, 1, P - 1); +end; + +procedure TGraalClient.Fail(const Why: string); +begin + LastError := Why; + Log(Why); + Disconnect; + FInRaw := ''; + FInPlain := ''; + FRawPending := 0; +end; + +procedure TGraalClient.DeliverMessage(const Msg: string); +var + Id: Integer; +begin + if Msg = '' then Exit; + Id := Ord(Msg[1]) - $20; + Inc(FMessagesIn); + if Assigned(FOnMessage) then + FOnMessage(Id, Copy(Msg, 2, MaxInt)); +end; + +procedure TGraalClient.SplitMessages; +var + P, E, N: Integer; + Msg: string; + R: TGReader; +begin + P := 1; + N := Length(FInPlain); + while P <= N do + begin + if FRawPending > 0 then + begin + if N - P + 1 < FRawPending then Break; + Msg := Copy(FInPlain, P, FRawPending); + Inc(P, FRawPending); + FRawPending := 0; + if (Msg <> '') and (Msg[Length(Msg)] = #10) then + SetLength(Msg, Length(Msg) - 1); + DeliverMessage(Msg); + Continue; + end; + E := P; + while (E <= N) and (FInPlain[E] <> #10) do Inc(E); + if E > N then Break; + Msg := Copy(FInPlain, P, E - P); + P := E + 1; + if (Msg <> '') and (Ord(Msg[1]) - $20 = PLO_RAWDATA) then + begin + R := TGReader.Create(Copy(Msg, 2, MaxInt)); + try + FRawPending := R.ReadGInt3; + finally + R.Free; + end; + { a GINT3 length is at most 3670015, under InPendingMax } + Continue; + end; + DeliverMessage(Msg); + end; + if P > 1 then Delete(FInPlain, 1, P - 1); + if Length(FInPlain) > InPendingMax then + Fail('unfinished message from the server is past the limit'); +end; + +{ TAdventureClient } + +destructor TAdventureClient.Destroy; +begin + FOutCodec.Free; + FInCodec.Free; + inherited Destroy; +end; + +procedure TAdventureClient.ResetCodec; +begin + FOutCodec.Free; + FInCodec.Free; + FOutCodec := TGen5.Create(FKey); + FInCodec := TGen5.Create(FKey); + FLoginFrame := True; +end; + +procedure TAdventureClient.StartOffline(AKey: Byte); +begin + FKey := AKey and $7F; + ResetCodec; + FOut := ''; + FInRaw := ''; + FInPlain := ''; + FRawPending := 0; +end; + +function TAdventureClient.Connect(const Host: string; Port: Word): Boolean; +begin + FKey := Random(256) and $7F; + ResetCodec; + Result := inherited Connect(Host, Port); +end; + +function TAdventureClient.EncodeFrame(const Plain: string): string; +var + CType: Integer; +begin + if FLoginFrame then + begin + { the fixed "zlib, no cipher, no compression byte" login frame } + FLoginFrame := False; + Result := ZCompress(Plain); + Exit; + end; + Result := PackBody(Plain, CType); + FOutCodec.Apply(Result, CType); + Result := Chr(CType) + Result; +end; + +function TAdventureClient.DecodeFrame(const Body: string; out Plain: string): Boolean; +var + CType: Integer; + B: string; +begin + Plain := ''; + Result := False; + if (Body = '') or (FInCodec = nil) then Exit; + CType := Ord(Body[1]); + B := Copy(Body, 2, MaxInt); + FInCodec.Apply(B, CType); + case CType of + 1, 2: begin Plain := B; Result := True; end; + 3, 4: Result := ZDecompress(B, Plain); + 5, 6: Result := BZ2Decompress(B, Plain, InFrameMax); + end; +end; + +procedure TAdventureClient.SendLogin(const Account, Password, Language: string); +begin + { GCHAR type, GCHAR key, token, GSTRING account, GSTRING password, then + the comma list, on one line (v5x-clients.md, "Login"). A password of + 0xE0 bytes or more goes as 0xFF and its first 0xDF bytes, which is + what GString's cut at 223 bytes gives. } + SendPacket(ClientType, GChar(FKey) + ClientVersionToken + GString(Account) + + GString(Password) + LoginTail); + Flush; + SendPacket(PLI_LANGUAGE, Language); +end; + +function LoginTail: string; +var + I: Integer; +begin + Result := LoginPlatform; + for I := 1 to LoginMachineFields do + Result := Result + ',' + EmptyMachineField; +end; + +procedure TAdventureClient.SendToAll(const Text: string); +var + T: string; +begin + T := Copy(Text, 1, 200); + SendPacket(PLI_TOALL, GChar(Length(T)) + T); +end; + +end. diff --git a/graal-5.00r7-G3D22067/src/ListServer500.pas b/graal-5.00r7-G3D22067/src/ListServer500.pas new file mode 100644 index 0000000..a9c970c --- /dev/null +++ b/graal-5.00r7-G3D22067/src/ListServer500.pas @@ -0,0 +1,96 @@ +unit ListServer500; + +{ The server list for the rebuild's start screen. + + 5.00r7 itself has no listserver step: it logs into a game server it + calls Login (license/license.graal, port 14900 on the original), which + shows the server list as scripted GUI and moves the client on with a + server warp (178) (graal_analysis protocol/v5x-clients.md, "Login"). + The rebuild cannot show that scripted list, so its start screen asks a + Seihai listserver for the list instead, with the 3.x list request: id 7 + V2ENCRYPTKEYCL = GCHAR key + 'G3D30123' + 'newmain' and id 1 SERVERLIST + (account, password) in one plain zlib frame; the replies are gen 5, + keyed with that key. The reply ids are 0 (the list), 2 (status), 4 + (error, the connection closes); 3 and 5 are read as 2.22 reads them. + listserver.txt next to the program names the listserver; with none it is + listserver.graal.in on 14922. + + The id 0 layout is the 2.05 one, read by GStartScreen.ParseServerList. } + +interface + +uses + SysUtils, Classes, GTypes, Protocol500, GraalClient, GStartScreen; + +const + ListToken = ListVersionToken; + ListVersion = 'newmain'; + LS_V2ENCRYPTKEYCL = 7; + LS_SERVERLIST = 1; + LSO_SVRLIST = 0; + LSO_STATUS = 2; + LSO_SITEURL = 3; + LSO_ERROR = 4; + LSO_UPGURL = 5; + DefaultListPort = 14922; + DefaultListHost = 'listserver.graal.in'; + +type + TListServerClient = class(TAdventureClient) + private + FServers: TListServers; + FStatus, FSiteUrl, FUpgradeUrl, FError: string; + FGotList: Boolean; + procedure HandleMessage(Id: Integer; const Data: string); + procedure ReadList(const Data: string); + public + constructor Create; + { Queue and send id 7 then id 1. Call after Connect (or StartOffline). } + procedure SendRequest(const Account, Password: string); + property Servers: TListServers read FServers; + property Status: string read FStatus; + property SiteUrl: string read FSiteUrl; + property UpgradeUrl: string read FUpgradeUrl; + property Error: string read FError; + property GotList: Boolean read FGotList; + end; + +implementation + +{ TListServerClient } + +constructor TListServerClient.Create; +begin + inherited Create; + OnMessage := HandleMessage; +end; + +procedure TListServerClient.SendRequest(const Account, Password: string); +begin + SendPacket(LS_V2ENCRYPTKEYCL, GChar(Key) + ListToken + ListVersion); + SendPacket(LS_SERVERLIST, GString(Account) + GString(Password)); + Flush; +end; + +procedure TListServerClient.ReadList(const Data: string); +begin + FServers := ParseServerList(Data); + FGotList := True; +end; + +procedure TListServerClient.HandleMessage(Id: Integer; const Data: string); +begin + case Id of + LSO_SVRLIST: ReadList(Data); + LSO_STATUS: FStatus := StringReplace(Data, #13, #10, [rfReplaceAll]); + LSO_SITEURL: FSiteUrl := Data; + LSO_UPGURL: FUpgradeUrl := Data; + LSO_ERROR: + begin + FError := Data; + Disconnect; + end; + end; +end; + +end. diff --git a/graal-5.00r7-G3D22067/src/Protocol500.pas b/graal-5.00r7-G3D22067/src/Protocol500.pas new file mode 100644 index 0000000..65b66d6 --- /dev/null +++ b/graal-5.00r7-G3D22067/src/Protocol500.pas @@ -0,0 +1,316 @@ +{ Protocol500: message ids and constants of the 5.00r7 client (G3D22067). + + The original 5.00r7 (July 2007) is a Delphi launcher over a C++ engine + library for Windows; this rebuild runs on Linux and Windows. Names follow + gs2lib (graal_analysis protocol/packet-ids.md). Sources: + protocol/v5x-clients.md, version-profiles/5.00-6.03.toml, + version-profiles/lab-v5-2026-10-30.md and protocol/v5v6-lab-play.md. + 5.00r7 speaks the gen-5 wire of 2.22 to 4.20 with its own token, no tamper + check and no listserver: it logs into a game server it calls Login, and + plays only after that server sends a server warp (178). It handles 100 + server ids; every other id is ignored silently. } +unit Protocol500; + +{$IFDEF FPC}{$MODE DELPHI}{$H+}{$ENDIF} + +interface + +const + { The 8-byte version token in the login line (v5x-clients.md, "Login"; + the lab saw it on the wire). } + ClientVersionToken = 'G3D22067'; + ClientBuildLabel = '5.00r7'; + { Login type 5, gen-5 cipher on the server, as 2.22. } + ClientType = 5; + { After the password, the login line ends with an unprefixed comma list: + the platform, then three machine fields (MD5 hex of the Windows product + id, the adapter MAC and the C: volume serial on the original). The + rebuild reads no machine values: each field goes as "" (two quote + marks), the value the real 5.00r7 sent for its MAC field in the lab. } + LoginPlatform = 'win'; + LoginMachineFields = 3; + EmptyMachineField = '""'; + { The name 5.00r7 gives the first server it reaches. While the current + server's name starts with "login" (any case) it draws no characters + and no HUD (lab-v5-2026-10-30.md, "Login mode"). } + FirstServerName = 'Login'; + { The built-in Login server port (license.graal line 2 on the original). } + LoginServerPort = 14900; + { 5.00r7 has no listserver step. The rebuild's start screen still gets a + list from a Seihai listserver with the 3.x list hello (id 7 + key + + this + "newmain"), because it cannot show the Login server's scripted + list; see ListServer500. } + ListVersionToken = 'G3D30123'; + + { 5.00r7 never sends PLI_TAMPERCHECK (39) (version-profiles/5.00-6.03.toml, + tampercheck = false). } + + { gen-5 cipher: the same LCG as gen 3 } + CipherSeed: Cardinal = $04A80B38; + CipherMul: Cardinal = $08088405; + { XOR group limits per compression type (codec-and-framing.md) } + XorGroupsRaw = 12; + XorGroupsPacked = 4; + { Compression bytes. Odd codes are the same compression with no XOR. } + CompressNone = 2; + CompressZlib = 4; + CompressBz2 = 6; + { Buffer size thresholds for the compression choice (client-versions.md, + "Gen-5 send on the client"). } + ZlibFrom = $30; + Bz2From = $1000; + + { The out buffer is sent at the end of each tick. 5.00r7's own threshold + for an early flush is not traced; this one keeps a raw body under the + u16be frame length. } + OutFlushAt = 60000; + OutDropAt = $40000; { more than 256 KB queued drops the link } + { Receive limits. These are the rebuild's, not 2.22's: they keep a hostile + server from growing the client without bound. } + InFrameMax = 16 * 1024 * 1024; { one inflated frame } + InPendingMax = 4 * 1024 * 1024; { an unfinished message } + TickMs = 50; { the frame gate (the lab saw 0.5 tiles per 50 ms) } + + { client -> server } + PLI_LEVELWARP = 0; + PLI_BOARDMODIFY = 1; + PLI_PLAYERPROPS = 2; + PLI_NPCPROPS = 3; + PLI_BOMBADD = 4; + PLI_BOMBDEL = 5; + PLI_TOALL = 6; + PLI_FLAGSET = 18; + PLI_FLAGDEL = 19; + PLI_WANTFILE = 23; + PLI_SHOWIMG = 24; + PLI_PRIVATEMESSAGE = 28; + PLI_LEVELWARPMOD = 30; + PLI_PACKETCOUNT = 31; + PLI_UPDATEFILE = 34; + PLI_ADJACENTLEVEL = 35; + PLI_LANGUAGE = 37; + PLI_TRIGGERACTION = 38; + PLI_TAMPERCHECK = 39; + PLI_PROCESSLIST = 44; + PLI_UPDATEGANI = 157; + + { server -> client } + PLO_LEVELBOARD = 0; + PLO_LEVELLINK = 1; + PLO_BADDYPROPS = 2; + PLO_NPCPROPS = 3; + PLO_LEVELCHEST = 4; + PLO_LEVELSIGN = 5; + PLO_LEVELNAME = 6; + PLO_BOARDMODIFY = 7; + PLO_OTHERPLPROPS = 8; + PLO_PLAYERPROPS = 9; + PLO_ISLEADER = 10; + PLO_BOMBADD = 11; + PLO_BOMBDEL = 12; + PLO_TOALL = 13; + PLO_PLAYERWARP = 14; + PLO_WARPFAILED = 15; + PLO_DISCMESSAGE = 16; + PLO_ITEMADD = 22; + PLO_ITEMDEL = 23; + PLO_NPCMOVED = 24; + PLO_SIGNATURE = 25; + PLO_FLAGSET = 28; + PLO_NPCDEL = 29; + PLO_FILESENDFAILED = 30; + PLO_FLAGDEL = 31; + PLO_SHOWIMGPLAYER = 32; + PLO_NPCWEAPONADD = 33; + PLO_NPCWEAPONDEL = 34; + PLO_PRIVATEMESSAGE = 37; + PLO_PUSHAWAY = 38; + PLO_LEVELMODTIME = 39; + PLO_HURTPLAYER = 40; + PLO_STARTMESSAGE = 41; + PLO_NEWWORLDTIME = 42; + PLO_DEFAULTWEAPON = 43; + PLO_HASNPCSERVER = 44; + PLO_FILEUPTODATE = 45; + PLO_HITOBJECTS = 46; + PLO_STAFFGUILDS = 47; + PLO_TRIGGERACTION = 48; + PLO_PLAYERWARP2 = 49; + PLO_LARGEFILESTART = 68; + PLO_LARGEFILEEND = 69; + PLO_PROFILE = 75; + PLO_RAWDATA = 100; + PLO_BOARDPACKET = 101; + PLO_FILE = 102; + PLO_NPCDEL2 = 150; + PLO_HIDENPCS = 151; + PLO_SAY2 = 153; + PLO_FREEZEPLAYER2 = 154; + PLO_UNFREEZEPLAYER = 155; + PLO_SETACTIVELEVEL = 156; + PLO_MOVE = 165; + PLO_SHOWIMGNPC = 166; + PLO_UNKNOWN168 = 168; + PLO_UPGRADEURL = 169; + PLO_GHOSTMODE = 170; + PLO_BIGMAP = 171; + PLO_MINIMAP = 172; + PLO_GHOSTTEXT = 173; + PLO_GHOSTICON = 174; + PLO_SHOOT = 175; + PLO_KINGDOMSMODE = 176; + PLO_NEWWORLDMODE = 177; + PLO_SERVERWARP = 178; + PLO_RPGWINDOW = 179; + PLO_STATUSLIST = 180; + PLO_UNKNOWN181 = 181; + PLO_LISTPROCESSES = 182; + PLO_HASPROCESSRUNNING = 183; + PLO_TAKESCREENSHOT = 184; + PLO_BOARDHEIGHTS = 185; + PLO_BOARDMODIFY2 = 186; + PLO_UNKNOWN190 = 190; { raises onServerListerConnect on the Login server } + PLO_CLEARWEAPONS = 194; + PLO_GANISCRIPT = 195; + + { player props (2.1+ forms). No 5.x prop parser was read: the sets are + 3.153's, plus X2 / Y2 / Z2 (78 to 80), which the lab saw 5.x send. } + PLPROP_NICKNAME = 0; + PLPROP_MAXPOWER = 1; + PLPROP_CURPOWER = 2; + PLPROP_RUPEESCOUNT = 3; + PLPROP_ARROWSCOUNT = 4; + PLPROP_BOMBSCOUNT = 5; + PLPROP_GLOVEPOWER = 6; + PLPROP_BOMBPOWER = 7; + PLPROP_SWORDPOWER = 8; + PLPROP_SHIELDPOWER = 9; + PLPROP_GANI = 10; + PLPROP_HEADGIF = 11; + PLPROP_CURCHAT = 12; + PLPROP_COLORS = 13; + PLPROP_ID = 14; + PLPROP_X = 15; + PLPROP_Y = 16; + PLPROP_SPRITE = 17; + PLPROP_STATUS = 18; + PLPROP_CARRYSPRITE = 19; + PLPROP_CURLEVEL = 20; + PLPROP_HORSEGIF = 21; + PLPROP_HORSEBUSHES = 22; + PLPROP_EFFECTCOLORS = 23; + PLPROP_CARRYNPC = 24; + PLPROP_APCOUNTER = 25; + PLPROP_MAGICPOINTS = 26; + PLPROP_KILLSCOUNT = 27; + PLPROP_DEATHSCOUNT = 28; + PLPROP_ONLINESECS = 29; + PLPROP_IPADDR = 30; + PLPROP_UDPPORT = 31; + PLPROP_ALIGNMENT = 32; + PLPROP_ADDITFLAGS = 33; + PLPROP_ACCOUNTNAME = 34; + PLPROP_BODYIMG = 35; + PLPROP_RATING = 36; + PLPROP_GATTRIB1 = 37; + PLPROP_GATTRIB5 = 41; + PLPROP_ATTACHNPC = 42; + PLPROP_GMAPLEVELX = 43; + PLPROP_GMAPLEVELY = 44; + PLPROP_Z = 45; + PLPROP_GATTRIB6 = 46; + PLPROP_GATTRIB9 = 49; + PLPROP_JOINLEAVELVL = 50; + PLPROP_PCONNECTED = 51; + PLPROP_PLANGUAGE = 52; + PLPROP_PSTATUSMSG = 53; + PLPROP_GATTRIB10 = 54; + PLPROP_GATTRIB30 = 74; + PLPROP_OSTYPE = 75; + PLPROP_TEXTCODEPAGE = 76; + PLPROP_X2 = 78; + PLPROP_Y2 = 79; + PLPROP_Z2 = 80; + + { What 5.00r7 says about itself in its first props: OSTYPE 'win' (lab: + nickname, colours, language, win, then the position); the code page is + the 3.04 lab value, assumed. } + OsType = 'win'; + TextCodePage = 1250; + +function PLOName(Id: Integer): string; +{ True for the 100 server ids 5.00r7's receive switch has a case for. } +function PLOKnown(Id: Integer): Boolean; + +implementation + +uses + SysUtils; + +function PLOKnown(Id: Integer): Boolean; +begin + { v5x-clients.md, "Server -> client ids (5.00r7)" } + case Id of + 0..25, 27..43, 45..49, 67..69, 74, 75, 82, 84, 101, 102, 104..107, 131..134, + 140, 150, 151, 153..156, 165, 166, 168..176, 178..187, 189..191, 193..195, 197: + Result := True; + else + Result := False; + end; +end; + +function PLOName(Id: Integer): string; +begin + case Id of + PLO_LEVELBOARD: Result := 'LEVELBOARD'; + PLO_LEVELLINK: Result := 'LEVELLINK'; + PLO_BADDYPROPS: Result := 'BADDYPROPS'; + PLO_NPCPROPS: Result := 'NPCPROPS'; + PLO_LEVELCHEST: Result := 'LEVELCHEST'; + PLO_LEVELSIGN: Result := 'LEVELSIGN'; + PLO_LEVELNAME: Result := 'LEVELNAME'; + PLO_BOARDMODIFY: Result := 'BOARDMODIFY'; + PLO_OTHERPLPROPS: Result := 'OTHERPLPROPS'; + PLO_PLAYERPROPS: Result := 'PLAYERPROPS'; + PLO_ISLEADER: Result := 'ISLEADER'; + PLO_TOALL: Result := 'TOALL'; + PLO_PLAYERWARP: Result := 'PLAYERWARP'; + PLO_WARPFAILED: Result := 'WARPFAILED'; + PLO_DISCMESSAGE: Result := 'DISCMESSAGE'; + PLO_SIGNATURE: Result := 'SIGNATURE'; + PLO_FLAGSET: Result := 'FLAGSET'; + PLO_FILESENDFAILED: Result := 'FILESENDFAILED'; + PLO_SHOWIMGPLAYER: Result := 'SHOWIMGPLAYER'; + PLO_NPCWEAPONADD: Result := 'NPCWEAPONADD'; + PLO_NPCWEAPONDEL: Result := 'NPCWEAPONDEL'; + PLO_PRIVATEMESSAGE: Result := 'PRIVATEMESSAGE'; + PLO_LEVELMODTIME: Result := 'LEVELMODTIME'; + PLO_STARTMESSAGE: Result := 'STARTMESSAGE'; + PLO_NEWWORLDTIME: Result := 'NEWWORLDTIME'; + PLO_DEFAULTWEAPON: Result := 'DEFAULTWEAPON'; + PLO_HASNPCSERVER: Result := 'HASNPCSERVER'; + PLO_FILEUPTODATE: Result := 'FILEUPTODATE'; + PLO_STAFFGUILDS: Result := 'STAFFGUILDS'; + PLO_PLAYERWARP2: Result := 'PLAYERWARP2'; + PLO_PROFILE: Result := 'PROFILE'; + PLO_RAWDATA: Result := 'RAWDATA'; + PLO_BOARDPACKET: Result := 'BOARDPACKET'; + PLO_FILE: Result := 'FILE'; + PLO_SAY2: Result := 'SAY2'; + PLO_SETACTIVELEVEL: Result := 'SETACTIVELEVEL'; + PLO_UNKNOWN168: Result := 'UNKNOWN168'; + PLO_GHOSTICON: Result := 'GHOSTICON'; + PLO_RPGWINDOW: Result := 'RPGWINDOW'; + PLO_STATUSLIST: Result := 'STATUSLIST'; + PLO_SERVERWARP: Result := 'SERVERWARP'; + PLO_BOARDMODIFY2: Result := 'BOARDMODIFY2'; + PLO_LISTPROCESSES: Result := 'LISTPROCESSES'; + PLO_UNKNOWN190: Result := 'UNKNOWN190'; + PLO_CLEARWEAPONS: Result := 'CLEARWEAPONS'; + PLO_GANISCRIPT: Result := 'GANISCRIPT'; + else + Result := 'PLO_' + IntToStr(Id); + end; +end; + +end. diff --git a/graal-5.00r7-G3D22067/src/RunMode.pas b/graal-5.00r7-G3D22067/src/RunMode.pas new file mode 100644 index 0000000..3702a1e --- /dev/null +++ b/graal-5.00r7-G3D22067/src/RunMode.pas @@ -0,0 +1,338 @@ +{ RunMode: what a stress run needs around the game loop, and nothing the + original client had: a clock in microseconds, a stop request from + SIGTERM / SIGINT (Ctrl+Break / Ctrl+C on Windows), the peak resident set, + a histogram of tick times, a seeded walker, and JSON output. } +unit RunMode; + +{$IFDEF FPC}{$MODE DELPHI}{$H+}{$ENDIF} + +interface + +uses + SysUtils, GLevel; + +{ Microseconds from an arbitrary start, monotonic where the OS allows. } +function MonoUs: Int64; + +{ Installs the handlers; StopRequested turns True when one fires. } +procedure InstallStopHandlers; +function StopRequested: Boolean; + +{ Peak resident set in KiB, or -1 where it is not known. } +function PeakRssKiB: Int64; + +type + { Tick times in 10 us buckets up to 100 ms; longer ticks count in the + last bucket and in Max. } + TTickHistogram = class + private + FBuckets: array of Integer; + FCount: Int64; + FMaxUs: Int64; + public + constructor Create; + procedure Add(Us: Int64); + { The q-th quantile (0..1) in ms. } + function QuantileMs(Q: Double): Double; + function MaxMs: Double; + property Count: Int64 read FCount; + end; + + TWalkMode = (wmScript, wmIdle, wmRandom); + + { The stress-run walker: a new random direction every WalkTicks ticks, + and every LinkEveryTicks it heads for the nearest link of the level + until it has gone through or GiveUpTicks pass. } + TWalker = class + private + FSeed: Cardinal; + FDir: Integer; + FSeekUntil: Integer; + FSeekLevel: string; + function Next(N: Integer): Integer; + public + Mode: TWalkMode; + WalkTicks: Integer; + LinkEveryTicks: Integer; { 0 = never } + GiveUpTicks: Integer; + constructor Create(Seed: Cardinal); + { The direction to hold this tick, or -1. } + function DirAt(Tick: Integer; Level: TAdventureLevel; PX, PY: Double): Integer; + end; + +{ A JSON string literal with the needed escapes. } +function JsonStr(const S: string): string; +{ A number with a dot and three decimals, whatever the locale. } +function JsonMs(V: Double): string; + +implementation + +uses +{$IFDEF FPC} + {$IFDEF UNIX} BaseUnix, Unix, {$ENDIF} +{$ENDIF} +{$IFDEF MSWINDOWS} Windows, {$ENDIF} + Classes; + +var + Stop: Boolean = False; + +{$IFDEF MSWINDOWS} +var + PerfFreq: Int64 = 0; +{$ENDIF} + +function MonoUs: Int64; +{$IFDEF MSWINDOWS} +var + C: Int64; +begin + if PerfFreq = 0 then QueryPerformanceFrequency(PerfFreq); + QueryPerformanceCounter(C); + Result := Trunc(C / PerfFreq * 1000000.0); +end; +{$ELSE} +{$IFDEF FPC} +var + TV: TTimeVal; +begin + fpGetTimeOfDay(@TV, nil); + Result := Int64(TV.tv_sec) * 1000000 + TV.tv_usec; +end; +{$ELSE} +begin + Result := Trunc(Now * 86400000000.0); +end; +{$ENDIF} +{$ENDIF} + +{$IFDEF MSWINDOWS} +function CtrlHandler(CtrlType: DWORD): BOOL; stdcall; +begin + Stop := True; + Result := True; { handled: the main loop logs out and exits } +end; +{$ENDIF} + +{$IFDEF FPC}{$IFDEF UNIX} +procedure SigHandler(Sig: cint); cdecl; +begin + Stop := True; +end; +{$ENDIF}{$ENDIF} + +procedure InstallStopHandlers; +begin +{$IFDEF MSWINDOWS} + SetConsoleCtrlHandler(@CtrlHandler, True); +{$ENDIF} +{$IFDEF FPC}{$IFDEF UNIX} + fpSignal(SIGTERM, SignalHandler(@SigHandler)); + fpSignal(SIGINT, SignalHandler(@SigHandler)); +{$ENDIF}{$ENDIF} +end; + +function StopRequested: Boolean; +begin + Result := Stop; +end; + +function PeakRssKiB: Int64; +{$IFDEF LINUX} +var + F: TextFile; + Line: string; + I: Integer; +begin + Result := -1; + if not FileExists('/proc/self/status') then Exit; + AssignFile(F, '/proc/self/status'); + {$I-} Reset(F); {$I+} + if IOResult <> 0 then Exit; + try + while not Eof(F) do + begin + ReadLn(F, Line); + if Copy(Line, 1, 6) = 'VmHWM:' then + begin + Delete(Line, 1, 6); + I := Pos('kB', Line); + if I > 0 then Line := Copy(Line, 1, I - 1); + Result := StrToInt64Def(Trim(Line), -1); + Exit; + end; + end; + finally + CloseFile(F); + end; +end; +{$ELSE} +begin + Result := -1; +end; +{$ENDIF} + +{ TTickHistogram } + +const + BucketUs = 10; + BucketCount = 10000; { 100 ms } + +constructor TTickHistogram.Create; +begin + inherited Create; + SetLength(FBuckets, BucketCount); +end; + +procedure TTickHistogram.Add(Us: Int64); +var + B: Int64; +begin + if Us < 0 then Us := 0; + B := Us div BucketUs; + if B >= BucketCount then B := BucketCount - 1; + Inc(FBuckets[B]); + Inc(FCount); + if Us > FMaxUs then FMaxUs := Us; +end; + +function TTickHistogram.QuantileMs(Q: Double): Double; +var + Want, Seen: Int64; + I: Integer; +begin + Result := 0; + if FCount = 0 then Exit; + Want := Trunc(Q * FCount); + if Want >= FCount then Want := FCount - 1; + Seen := 0; + for I := 0 to BucketCount - 1 do + begin + Inc(Seen, FBuckets[I]); + if Seen > Want then + begin + { the bucket's upper edge, but never above the largest tick seen } + Result := ((I + 1) * BucketUs) / 1000.0; + if Result > MaxMs then Result := MaxMs; + Exit; + end; + end; + Result := MaxMs; +end; + +function TTickHistogram.MaxMs: Double; +begin + Result := FMaxUs / 1000.0; +end; + +{ TWalker } + +constructor TWalker.Create(Seed: Cardinal); +begin + inherited Create; + FSeed := Seed; + FDir := -1; + FSeekUntil := -1; + WalkTicks := 2; + GiveUpTicks := 200; +end; + +{ A small LCG of its own, so the walk does not move the RTL's Random + (which picks the gen-3 key). } +{$IFOPT Q+}{$DEFINE WQ}{$Q-}{$ENDIF} +{$IFOPT R+}{$DEFINE WR}{$R-}{$ENDIF} +function TWalker.Next(N: Integer): Integer; +begin + FSeed := FSeed * 1103515245 + 12345; + Result := Integer((FSeed shr 16) mod Cardinal(N)); +end; +{$IFDEF WR}{$R+}{$ENDIF} +{$IFDEF WQ}{$Q+}{$ENDIF} + +function TWalker.DirAt(Tick: Integer; Level: TAdventureLevel; PX, PY: Double): Integer; +var + I, Best: Integer; + CX, CY, D, BestD, DX, DY: Double; +begin + Result := -1; + if Mode = wmIdle then Exit; + { the body's centre, as the link test uses } + CX := PX + 1.5; + CY := PY + 2; + if (FSeekUntil >= 0) and ((Tick > FSeekUntil) or (Level.Name <> FSeekLevel)) then + FSeekUntil := -1; { gone through, or given up } + if (FSeekUntil < 0) and (LinkEveryTicks > 0) and (Tick > 0) and + (Tick mod LinkEveryTicks = 0) and (Length(Level.Links) > 0) then + begin + FSeekUntil := Tick + GiveUpTicks; + FSeekLevel := Level.Name; + end; + if FSeekUntil >= 0 then + begin + Best := -1; + BestD := 0; + for I := 0 to High(Level.Links) do + begin + DX := Level.Links[I].X + Level.Links[I].W / 2 - CX; + DY := Level.Links[I].Y + Level.Links[I].H / 2 - CY; + D := Abs(DX) + Abs(DY); + if (Best < 0) or (D < BestD) then + begin + Best := I; + BestD := D; + end; + end; + if Best >= 0 then + begin + DX := Level.Links[Best].X + Level.Links[Best].W / 2 - CX; + DY := Level.Links[Best].Y + Level.Links[Best].H / 2 - CY; + if Abs(DX) >= Abs(DY) then + begin + if DX < 0 then Result := 1 else Result := 3; { left / right } + end + else if DY < 0 then Result := 0 else Result := 2; { up / down } + Exit; + end; + end; + if (WalkTicks <= 1) or (Tick mod WalkTicks = 0) or (FDir < 0) then + FDir := Next(4); + Result := FDir; +end; + +function JsonStr(const S: string): string; +var + I: Integer; + C: Char; +begin + Result := '"'; + for I := 1 to Length(S) do + begin + C := S[I]; + case C of + '"': Result := Result + '\"'; + '\': Result := Result + '\\'; + #0..#31, #127..#255: Result := Result + '\u00' + IntToHex(Ord(C), 2); + else + Result := Result + C; + end; + end; + Result := Result + '"'; +end; + +function JsonMs(V: Double): string; +var + W: Int64; + F: Integer; +begin + if V < 0 then V := 0; + W := Trunc(V); + F := Round((V - W) * 1000); + if F >= 1000 then + begin + Inc(W); + Dec(F, 1000); + end; + Result := IntToStr(W) + '.' + Format('%.3d', [F]); +end; + +end. diff --git a/graal-5.00r7-G3D22067/src/StartScreen500.pas b/graal-5.00r7-G3D22067/src/StartScreen500.pas new file mode 100644 index 0000000..cda7565 --- /dev/null +++ b/graal-5.00r7-G3D22067/src/StartScreen500.pas @@ -0,0 +1,113 @@ +{ StartScreen500: what 5.00r7 plugs into the shared start screen + (common/GStartScreen.pas): its list step and its character. + + The list comes from a Seihai listserver (ListServer500), since the + rebuild cannot show the Login server's scripted list. The name of the + server picked there becomes the client's server name, as if the Login + server had already warped it there, so the player is drawn from the + start. + + The start screen is this project's own (common/GStartScreen.pas); the + original start window and its pictures are never drawn. } +unit StartScreen500; + +{$IFDEF FPC}{$MODE DELPHI}{$H+}{$ENDIF} + +interface + +uses + GSurface, GStartScreen, GraalClient, ListServer500, Adventure; + +type + TListFetch500 = class(TListFetch) + public + Client: TListServerClient; + StartMs: Int64; + procedure Start(const Host: string; Port: Integer; + const Account, Password: string); override; + procedure Poll; override; + destructor Destroy; override; + end; + + { Draws G's player, idle and facing down, for the start screen. } + TCharacter500 = class + public + G: TAdventure; + procedure Draw(S: TGSurface; X, Y: Integer; const Nick: string); + end; + +implementation + +uses + SysUtils, Classes, GTypes; + +procedure TListFetch500.Start(const Host: string; Port: Integer; + const Account, Password: string); +begin + FreeAndNil(Client); + SetLength(Servers, 0); + Done := False; + Failed := False; + StartMs := NowMs; + Client := TListServerClient.Create; + Status := Format('asking %s:%d for the server list...', [Host, Port]); + if not Client.Connect(Host, Port) then + begin + Status := Format('no listserver at %s:%d (%s)', [Host, Port, Client.LastError]); + Failed := True; + Exit; + end; + Client.SendRequest(Account, Password); +end; + +procedure TListFetch500.Poll; +begin + if (Client = nil) or Done or Failed then Exit; + Client.Poll; + if Client.Status <> '' then + Status := StringReplace(Client.Status, #10, ' ', [rfReplaceAll]); + if Client.Error <> '' then + begin + Status := 'listserver: ' + Client.Error; + Failed := True; + Exit; + end; + if Client.GotList then + begin + Servers := Client.Servers; + Done := True; + if Client.Status = '' then + Status := Format('%d servers', [Length(Servers)]); + Client.Disconnect; + Exit; + end; + if not Client.Connected then + begin + Status := 'the listserver closed the link: ' + Client.LastError; + Failed := True; + end + else if NowMs - StartMs > 8000 then + begin + Status := 'the listserver did not answer'; + Failed := True; + Client.Disconnect; + end; +end; + +destructor TListFetch500.Destroy; +begin + Client.Free; + inherited Destroy; +end; + +procedure TCharacter500.Draw(S: TGSurface; X, Y: Integer; const Nick: string); +begin + G.Player.Nickname := Nick; + G.Player.X := 0; + G.Player.Y := 0; + G.Player.Dir := 2; + G.Player.AniName := 'idle'; + G.DrawPlayer(G.Player, -X, -Y); +end; + +end. diff --git a/graal-5.00r7-G3D22067/tests/Capture500.inc b/graal-5.00r7-G3D22067/tests/Capture500.inc new file mode 100644 index 0000000..dffe185 --- /dev/null +++ b/graal-5.00r7-G3D22067/tests/Capture500.inc @@ -0,0 +1,97 @@ +{ Frames of a real 2.22 session (graal-decompile/live-trace/item-drops/ + b4_222.pcap, client port 52678, key 58), as hex: the client's frames 2 to + 13 (the login frame, which holds the credentials, is left out) and the + server's first 8 frames. Each is the body after the u16be length: + compression byte, then the XORed body. CapturePlainCS are the decoded + client bodies; the server bodies are checked by length and bzip2 CRC. + Decoded with graal-decompile/lab/decode_tcp.py's rule. } +const + CaptureKey = 58; + CaptureCS: array[0..11] of string = ( + '02175dbfb1b8a85c3d545ea5f65df8128989fe9bc5e6', + '04aebbd76843760a4a6f2f7b20aa458006cf4b4d2cc9cc4bd72bc84be7724295' + + 'c9c84cc1219397af50905b8c4da6a800a6c528bd48afc2d6d800cca80432f44c' + + 'b99414348a4b4a934058bb37233531c500a4545749414bc5c8c8c45e4141c151' + + '2144dd352f1d685c46b64a79665e4a8e82660b9785261700c3483c13', + '02f6e798', + '02786bfa', + '023c6bfa87c3349264202c414eeda2f47f', + '021347e9ea1604a68378537b2c264df2ee4f5610973e0794', + '02940a8fd5ac1780ab', + '021aa284', + '02dc169c', + '028391645f', + '02e6e6a921053477229a3ae633530837f1', + '02dad56e0a658f452a9e9019ed' + ); + CapturePlainCS: array[0..11] of string = ( + '45456e676c6973680a47250e4d0f962b03ede6310a', + '42267732218d706c69737469636f6e656174696e672e706e670a42267732218d' + + '706c69737469636f6e686964696e672e706e670a42267732218d706c69737469' + + '636f6e6e6f20706d732e706e670a42267732218d706c69737469636f6e727069' + + '6e672e706e670a3267722e783d33300a3267722e793d33302e350a2220287374' + + '7562737475622b8d68656164302e706e672d22202a243232343f202020412054' + + '27456e676c6973686b2477696e646c2029840a38290a', + '38290a', + '38290a', + '462020205f556c6566746d6f7573650a', + '213f42222225452546255525560a222a2573776f72640a', + '222a2469646c650a', + '38290a', + '38290a', + '2d5e640a', + '462020205f556c6566746d6f7573650a', + '222a2573776f72640a38290a' + ); + CaptureSC: array[0..7] of string = ( + '042a84748299b2fc654e24b747721c8a953b4ada0e33a44e66da242d85e6031a' + + 'a67062644b713495258f24b7354cff1f7738f35b58d94e09d01b1e599657fb76' + + 'dfae9efd4a74be757e76be07375ca63ae7e034cc2ab8e6e68e9b6e10064bc369' + + 'a6159570717d38cd4b288cce0ccd73ce20a9e08de65508732a850a61ac990981' + + '2a0663cae89de1dda07319ef4f16e3d5a7e5145eaf6657b0fc70767539862022' + + 'e4e6684cc8643569368ebbbd3e5c3b235247c8741e8c20deb85cfa07a70c1f4e' + + '38c9474fe462d21820b6ae9248bc2af83070fcc191d45a8417ddfbb6a6af5050' + + 'c684ca06d02b1ea0efa7ede204726a32a122a78b416b596be5a27b2eb28d1b40' + + 'a2256b4d567ce10378882422f8093cc20157ce5418bf89b1c527da306ef00d73' + + '582d05764ad2f4d6238a2ea38e3f2176b3b696443ba7f39ae9934df2b5dbbaa5' + + '5a6a8c9dc8923fcb1459a51baa326effcaf25c9226e423c4a46e223693b4dd4e' + + '34ab20c9ea6cc3e0a07ffc323decf943117906d6a4c360e35c312064ad4d99db' + + '2e6a82caae5044e4147337f13ed7562275a68fba85ca02201881893ba8b78741' + + '826dc98c2e158bdaba0ed678f1f5096cdaaafabdde8b7f79f3fce4cf43ddb97f' + + '1f00a3e6d6a05075e92c7770847b58c25e5c402aa9b5c3a0554830da917f6c0b' + + 'aab6045b561804917905b6d6de3ef60b9d4631294600f17e14c16a232ce04068' + + '2d678c96a33a208a468dc358171538ef95489dde825e8317abcf8875204ebb0d' + + '37d09c1d34c2f2e0bdba5f820d83dae6f9ef14e0d5148c7a7d528f9a0f6e97b2' + + '06b43aa8217bb114a34b10ca3a2a25f664b718dcf230524a9f8f60c2ff240ddb' + + '20c4eba89695ff963ba6b368bede704615eac4848b7b85f329cbf107727efa2e' + + 'bc3a5d8573bc2ffcbdc401e38de0ebf0accc2c346ef3e5b85d5d502560c5691e' + + '5e9c7f6c6dd33ba4611b6bbb6e9d4b2159b3eefc5828fc63f1f0f49e56e1643e' + + '09a7d4a194c2d7c22b2a9c6b58ce6cf87ee95fae0b6a8c5f2cdfe2dcf9058ee5' + + 'b23b', + '04f28f207925871560d62453848ae90a7c10c41036c46c615c98a7d67bb4d268' + + 'a312b1f10736be588495d5cd39c9c94d8451621140d5a3d158245ed1839b7711' + + '99947f3e260c23b01de97e49571de14ae3694b53a43f22a9a0abd98c92cde529' + + '50a4c4aa4c755c4bb9a67595c1f537f5b8e589fb2768f45f8f262dda74e8d21b' + + 'f7193064c4842933e62c58b262cd862d3b4c2cf60824078ed8389c386b3b4ff3' + + '7db8fc9d84de902738ca', + '043a7bc9c86168585755cab023f9fec59bbcd5b91c7574d38be273f3cb527353' + + 'f34a14b4ca93800a0cf50af2d2151593f5f5959d7d3c5dfd42823d5d5c9767a6' + + '296814e42456a6160155a616152bd4d4289464e6a6e69796682a5483a515d38b' + + 'f4f2d3d290b9151081e2d492e292a2ccbc740590988e729946665e8906d4bc0a' + + '6d033d23534d2d234d7d234d6bb8d64a2c5a2bd1b456a26aad5d0e7591ad819e' + + '812990cf05000d874f78', + '063811b296ad20a7271501649c818f917d1affdff89018005931180000821006' + + '6a259c800600060606060001000180018000b000e6a049229b51a6800001a0d3' + + '4d18d218c864341a0d1a00d000d0c0a8a94f280d00034006803d40e14052acaa' + + '0a55319867a73d7954aa17c590548541507d0ce2acb4b48970092124ac276e2c' + + 'ec6fdbd078a615dce37951ca0a43c53e4d79bb94c7cb46ad5e9c1ee7e99999bc' + + '7d181899991b4201fab9dd2858110886209349b14530441939303de0ce335559' + + '244d62ca57425994a59702a44898aa0614492d0956120c149261491550248b48' + + '908feff17724538509048bd195e0', + '027815f05d042b', + '02741b759c414d', + '0220483c6d7e69', + '02807ecf9fc2' + ); + CapturePlainSCLen: array[0..7] of Integer = (1330, 200, 244, 8305, 6, 6, 6, 5); + CapturePlainSCCrc: array[0..7] of Cardinal = ($9AEEE343, $273C750B, $37583D60, $48BD195E, $802BB9EC, $52327830, $20D927E3, $A22AFA66); diff --git a/graal-5.00r7-G3D22067/tests/Test500.dpr b/graal-5.00r7-G3D22067/tests/Test500.dpr new file mode 100644 index 0000000..0a66a16 --- /dev/null +++ b/graal-5.00r7-G3D22067/tests/Test500.dpr @@ -0,0 +1,1222 @@ +{ Tests for the 5.00r7 rebuild. No framework: each check prints a line and + the run exits 1 if any failed. + + 5.00r7 keeps the gen-5 wire, so the gen-5 codec checks run against frames + of a real 2.22 session (Capture500.inc, the 2.22 capture); the login, + Login mode and server warp checks follow the 5.00r7 lab run + (graal_analysis version-profiles/lab-v5-2026-10-30.md). + Optional: GRAAL500_DATA = a 5.00r7 install, so the fuzzer also draws the + fuzzed players with real heads, bodies and ganis. } +program Test500; + +{$IFDEF FPC}{$MODE DELPHI}{$H+}{$ENDIF} +{$IFDEF MSWINDOWS}{$APPTYPE CONSOLE}{$ENDIF} + +uses + SysUtils, Classes, + GTypes in '../../common/GTypes.pas', + GZlib in '../../common/GZlib.pas', + GBzip2 in '../../common/GBzip2.pas', + GSocket in '../../common/GSocket.pas', + GLevel in '../../common/GLevel.pas', + GSurface in '../../common/GSurface.pas', + GArrays in '../../common/GArrays.pas', + GAni in '../../common/GAni.pas', + Protocol500 in '../src/Protocol500.pas', + GraalClient in '../src/GraalClient.pas', + Adventure in '../src/Adventure.pas', + GBuiltin in '../../common/GBuiltin.pas', + GStartScreen in '../../common/GStartScreen.pas', + ListServer500 in '../src/ListServer500.pas'; + +{$I Capture500.inc} + +type + { reaches the codec hooks } + TClientAccess = class(TAdventureClient); + +var + Passed, Failed, Skipped: Integer; + +procedure Check(Cond: Boolean; const What: string); +begin + if Cond then + begin + Inc(Passed); + WriteLn('ok ', What); + end + else + begin + Inc(Failed); + WriteLn('FAIL ', What); + end; +end; + +function Unhex(const H: string): string; +var + I: Integer; +begin + SetLength(Result, Length(H) div 2); + for I := 1 to Length(H) div 2 do + Result[I] := Chr(StrToInt('$' + Copy(H, 2 * I - 1, 2))); +end; + +{ Messages of a plain body, split on LF. } +procedure SplitLines(const Plain: string; L: TStrings); +var + P, E: Integer; +begin + L.Clear; + P := 1; + while P <= Length(Plain) do + begin + E := P; + while (E <= Length(Plain)) and (Plain[E] <> #10) do Inc(E); + L.Add(Copy(Plain, P, E - P)); + P := E + 1; + end; +end; + +{ A client frame as the server reads it: u16be, compression byte, XOR. } +function ServerReadFrame(Codec: TGen5; const Wire: string; out Plain: string): Boolean; +var + Len, CType: Integer; + B: string; +begin + Plain := ''; + Result := False; + if Length(Wire) < 3 then Exit; + Len := (Ord(Wire[1]) shl 8) or Ord(Wire[2]); + if Length(Wire) <> Len + 2 then Exit; + CType := Ord(Wire[3]); + B := Copy(Wire, 4, MaxInt); + Codec.Apply(B, CType); + case CType of + 2: begin Plain := B; Result := True; end; + 4: Result := ZDecompress(B, Plain); + 6: Result := BZ2Decompress(B, Plain, 1 shl 24); + end; +end; + +{ All frames in a sink's output, decoded in order. } +function ServerReadAll(Codec: TGen5; const Wire: string; Msgs: TStrings): Boolean; +var + P, Len: Integer; + Plain: string; + L: TStringList; +begin + Result := True; + Msgs.Clear; + L := TStringList.Create; + try + P := 1; + while P + 1 <= Length(Wire) do + begin + Len := (Ord(Wire[P]) shl 8) or Ord(Wire[P + 1]); + if not ServerReadFrame(Codec, Copy(Wire, P, Len + 2), Plain) then + begin + Result := False; + Exit; + end; + SplitLines(Plain, L); + Msgs.AddStrings(L); + Inc(P, Len + 2); + end; + finally + L.Free; + end; +end; + +{ A server frame for a gen-5 client. } +function ServerFrame(Codec: TGen5; const Plain: string): string; +var + B: string; + CType: Integer; +begin + B := PackBody(Plain, CType); + Codec.Apply(B, CType); + B := Chr(CType) + B; + Result := Chr(Length(B) shr 8) + Chr(Length(B) and $FF) + B; +end; + +function MsgId(const M: string): Integer; +begin + if M = '' then Result := -1 else Result := Ord(M[1]) - 32; +end; + +procedure TestGTypes; +var + R: TGReader; + S: string; +begin + Check(GChar(5) = '%', 'GCHAR 5 (login type of 2.22) is %'); + Check(GChar(39) = 'G', 'GCHAR 39 (PLI_TAMPERCHECK) is G'); + S := GShort(28671) + GInt3(3670015) + GInt5($DEADBEEF) + GString('walk'); + R := TGReader.Create(S); + try + Check(R.ReadGShort = 28671, 'GSHORT max round trip'); + Check(R.ReadGInt3 = 3670015, 'GINT3 max round trip'); + Check(R.ReadGInt5 = $DEADBEEF, 'GINT5 32-bit round trip'); + Check(R.ReadGString = 'walk', 'GSTRING round trip'); + Check(R.Eof and not R.Overrun, 'reader ends cleanly'); + finally + R.Free; + end; +end; + +procedure TestBzip2; +var + S, Z, P: string; + I, J: Integer; + AllOk: Boolean; +begin + Check(BZ2Crc('123456789') = $FC891918, 'bzip2 CRC check value'); + AllOk := True; + RandSeed := 22; + for I := 0 to 40 do + begin + case I mod 5 of + 0: S := StringOfChar(Chr(I), I * 300); + 1: begin S := ''; while Length(S) < I * 200 do S := S + 'abc' + Chr(Random(4) + 65); end; + 2: begin SetLength(S, I * 150); if S <> '' then FillChar(S[1], Length(S), 0); + if Length(S) > 10 then S[10] := 'x'; end; + 3: begin + SetLength(S, I * 97); + for J := 1 to Length(S) do S[J] := Chr(Random(256)); + end; + else + S := Copy(StringOfChar(#$FF, 300) + #$07, 1, I * 7); + end; + Z := BZ2Compress(S); + if not BZ2Decompress(Z, P, 1 shl 24) or (P <> S) then AllOk := False; + end; + Check(AllOk, 'bzip2: 41 buffers (runs, text, zeros, random) round trip'); + { the same round trip at a frame-sized buffer of random bytes } + SetLength(S, 70000); + for I := 1 to Length(S) do S[I] := Chr(Random(256)); + Check(BZ2Decompress(BZ2Compress(S), P, 1 shl 24) and (P = S), + 'bzip2: 70000 random bytes round trip'); + Check(not BZ2Decompress('BZh9 not bzip2 at all', P, 1000), 'bzip2: garbage is rejected'); + Z := BZ2Compress(StringOfChar('a', 5000)); + Check(not BZ2Decompress(Z, P, 4999), 'bzip2: output past the cap is rejected'); + Z[Length(Z) - 2] := Chr(Ord(Z[Length(Z) - 2]) xor 1); + Check(not BZ2Decompress(Z, P, 1 shl 24), 'bzip2: a wrong stream CRC is rejected'); +end; + +{ The real 2.22 frames: the decoder reads both directions, and the encoder + makes the client's uncompressed frames byte for byte. } +procedure TestGen5Capture; +var + Dec, Enc: TGen5; + I, CType, Raw, Same, NPacked: Integer; + Wire, Body, Plain, B, Mine: string; + C: TClientAccess; + AllPlain, CrcOk: Boolean; +begin + Dec := TGen5.Create(CaptureKey); + Enc := TGen5.Create(CaptureKey); + try + AllPlain := True; + Raw := 0; + Same := 0; + NPacked := 0; + for I := 0 to High(CaptureCS) do + begin + Wire := Unhex(CaptureCS[I]); + Wire := Chr(Length(Wire) shr 8) + Chr(Length(Wire) and $FF) + Wire; + if not ServerReadFrame(Dec, Wire, Plain) or (Plain <> Unhex(CapturePlainCS[I])) then + AllPlain := False; + { encode the same plain body again } + B := PackBody(Unhex(CapturePlainCS[I]), CType); + Enc.Apply(B, CType); + Mine := Chr(CType) + B; + Body := Unhex(CaptureCS[I]); + if Ord(Body[1]) = CompressNone then + begin + Inc(Raw); + if Mine = Body then Inc(Same); + end + else if (CType = Ord(Body[1])) then + Inc(NPacked); + end; + Check(AllPlain, Format('gen 5: %d real client frames decode (XOR + zlib)', + [Length(CaptureCS)])); + Check((Raw > 0) and (Same = Raw), Format( + 'gen 5: %d of %d uncompressed client frames re-encoded byte for byte', [Same, Raw])); + Check(NPacked = Length(CaptureCS) - Raw, + 'gen 5: the compression byte picked matches the client''s for every frame'); + Check(Dec.Iterator = Enc.Iterator, 'gen 5: encoder and decoder iterators stay in step'); + finally + Dec.Free; + Enc.Free; + end; + { the server's frames through the client's own receive path } + C := TClientAccess.Create; + try + C.StartOffline(CaptureKey); + CrcOk := True; + for I := 0 to High(CaptureSC) do + if not C.DecodeFrame(Unhex(CaptureSC[I]), Plain) or + (Length(Plain) <> CapturePlainSCLen[I]) or (BZ2Crc(Plain) <> CapturePlainSCCrc[I]) then + CrcOk := False; + Check(CrcOk, 'gen 5: the server''s first 8 frames decode (zlib, bz2 and raw)'); + Check(Ord(Unhex(CaptureSC[3])[1]) = CompressBz2, 'gen 5: the capture has a bz2 frame'); + finally + C.Free; + end; +end; + +{ The login as 5.00r7 sends it: the login line alone in the plain zlib + frame, ending with win and three machine fields, then 37 in its own + gen-5 frame; no tamper check. } +procedure TestLogin; +var + C: TAdventureClient; + Codec: TGen5; + Msgs: TStringList; + Wire, Plain: string; + Len: Integer; +begin + C := TAdventureClient.Create; + Codec := TGen5.Create(CaptureKey); + Msgs := TStringList.Create; + try + C.StartOffline(CaptureKey); + C.Sink := True; + C.SendLogin('acc', 'pw', 'English'); + C.Flush; + Wire := C.Sent; + Len := (Ord(Wire[1]) shl 8) or Ord(Wire[2]); + Check(ZDecompress(Copy(Wire, 3, Len), Plain) and + (Plain = '%' + Chr(CaptureKey + 32) + 'G3D22067' + GString('acc') + GString('pw') + + 'win,"","",""' + #10), + 'login: 5 (key, G3D22067, account, password, win and three machine fields) alone in the plain zlib frame'); + Check(ServerReadAll(Codec, Copy(Wire, Len + 3, MaxInt), Msgs) and + (Msgs.Count = 1) and (Msgs[0] = GChar(PLI_LANGUAGE) + 'English'), + 'login: 37 English in its own gen-5 frame, and no tamper check'); + Check(LoginTail = 'win,"","",""', 'login: the tail is win and three empty quoted fields'); + C.Sent := ''; + C.StartOffline(CaptureKey); + C.SendLogin('acc', StringOfChar('p', 300), 'English'); + Wire := C.Sent; + Len := (Ord(Wire[1]) shl 8) or Ord(Wire[2]); + Check(ZDecompress(Copy(Wire, 3, Len), Plain) and + (Pos(#255 + StringOfChar('p', 223) + 'win,', Plain) > 0), + 'login: a long password goes as 0xFF and its first 0xDF bytes'); + finally + Msgs.Free; + Codec.Free; + C.Free; + end; +end; + +{ The rebuild's list step (5.00r7 has none): id 7 with the key, G3D30123 + and newmain and id 1 in one plain zlib frame; the list, status and urls + back in gen 5. } +procedure TestListServer; +var + C: TListServerClient; + Codec, SCodec: TGen5; + Wire, Plain, List: string; + Len: Integer; +begin + C := TListServerClient.Create; + Codec := TGen5.Create(CaptureKey); + SCodec := TGen5.Create(CaptureKey); + try + C.StartOffline(CaptureKey); + C.Sink := True; + C.SendRequest('acc', 'pw'); + Wire := C.Sent; + Len := (Ord(Wire[1]) shl 8) or Ord(Wire[2]); + Check(ZDecompress(Copy(Wire, 3, Len), Plain) and + (Plain = GChar(7) + GChar(CaptureKey) + 'G3D30123newmain' + #10 + + GChar(1) + GString('acc') + GString('pw') + #10) and + (Length(Wire) = Len + 2), + 'list: id 7 (key, G3D30123, newmain) and id 1 (account, password) in one plain zlib frame'); + List := GChar(2) + + GChar(8) + GString('P Classic') + GString('English') + GString('A server') + + GString('http://x') + GString('2.22') + GString('12') + + GString('127.0.0.1') + GString('14802') + + GChar(8) + GString('Plain') + GString('') + GString('') + GString('') + + GString('') + GString('0') + GString('10.0.0.1') + GString('14900'); + C.FeedRaw(ServerFrame(SCodec, GChar(0) + List + #10 + GChar(2) + + 'Line one'#13'Line two' + #10 + GChar(3) + 'http://site' + #10 + + GChar(5) + 'http://up' + #10)); + Check(C.GotList and (Length(C.Servers) = 2), 'list: two servers read'); + if Length(C.Servers) = 2 then + begin + Check((C.Servers[0].Name = 'P Classic') and + (ServerDisplayName(C.Servers[0].Name) = 'Classic') and + (C.Servers[0].Players = '12') and (C.Servers[0].Host = '127.0.0.1') and + (C.Servers[0].Port = 14802), 'list: type prefix, name, players, ip, port'); + Check((ServerDisplayName(C.Servers[1].Name) = 'Plain') and + (C.Servers[1].Port = 14900), 'list: a silver server has no prefix'); + end; + Check((C.Status = 'Line one'#10'Line two') and (C.SiteUrl = 'http://site') and + (C.UpgradeUrl = 'http://up'), 'list: status, site and upgrade lines'); + Check((DefaultListHost = 'listserver.graal.in') and (DefaultListPort = 14922), + 'list: listserver.graal.in on 14922 by default'); + Check(Length(ParseServerList(GChar(5) + GChar(8) + GString('x'))) = 0, + 'list: a cut-off list gives no half-read server'); + finally + C.Free; + Codec.Free; + SCodec.Free; + end; +end; + +{ Reads and drops what the client sent, keeping the iterator in step. } +procedure Drain(G: TAdventure; Codec: TGen5); +var + M: TStringList; +begin + M := TStringList.Create; + try + G.Client.Flush; + ServerReadAll(Codec, G.Client.Sent, M); + G.Client.Sent := ''; + finally + M.Free; + end; +end; + +{ A TAdventure on a sink, logged in through the real server frames. } +function LoggedInGame(out Codec: TGen5): TAdventure; +var + I, Len: Integer; + Msgs: TStringList; + SrvOut: TGen5; +begin + Result := TAdventure.Create; + Result.UseWallClock := False; + Result.Client.StartOffline(CaptureKey); + Result.Client.Sink := True; + Result.Client.SendLogin('stubstub', 'pw', 'English'); + Result.Client.Flush; + Codec := TGen5.Create(CaptureKey); + { what the login sent: the login frame (no XOR) is skipped, the 37/39 + frame read, so the server-side iterator is in step } + Len := (Ord(Result.Client.Sent[1]) shl 8) or Ord(Result.Client.Sent[2]); + Msgs := TStringList.Create; + try + ServerReadAll(Codec, Copy(Result.Client.Sent, Len + 3, MaxInt), Msgs); + finally + Msgs.Free; + end; + Result.Client.Sent := ''; + SrvOut := TGen5.Create(CaptureKey); + try + for I := 0 to High(CaptureSC) do + Result.Client.FeedRaw(Chr(Length(Unhex(CaptureSC[I])) shr 8) + + Chr(Length(Unhex(CaptureSC[I])) and $FF) + Unhex(CaptureSC[I])); + finally + SrvOut.Free; + end; +end; + +procedure TestLoginBurst; +var + G: TAdventure; + Codec: TGen5; + Msgs: TStringList; + I, NUpd: Integer; + Props: string; +begin + G := LoggedInGame(Codec); + Msgs := TStringList.Create; + try + Check(G.LoggedIn and G.BoardLoaded and (G.Level.Name = 'onlinestartlocal.nw'), + 'burst: the server''s login frames (2.22 capture, same wire) log in and load the board'); + Check((G.Player.SwordImage = 'sword1.png') and (G.Player.ShieldImage = 'shield1.png') and + (G.Player.HeadImage = 'head0.png') and (G.Player.AniName = 'idle'), + 'burst: own props in their 2.1 forms (sword, shield, GANI, head)'); + Check((G.Ignored[190] = 0) and (G.Ignored[82] = 0) and (G.Ignored[194] = 0), + 'burst: 82, 190 and 194 have a case in 5.00r7'); + G.Player.Nickname := 'stubstub'; + G.Player.Status := 20; + for I := 0 to 4 do G.Player.Colors[I] := I + 1; + G.Tick; + Check(ServerReadAll(Codec, G.Client.Sent, Msgs), 'burst: the client''s frame decodes'); + for I := Msgs.Count - 1 downto 0 do + if Msgs[I] = '' then Msgs.Delete(I); + Props := ''; + NUpd := 0; + for I := 0 to Msgs.Count - 1 do + begin + if MsgId(Msgs[I]) = PLI_PLAYERPROPS then Props := Msgs[I]; + if MsgId(Msgs[I]) = PLI_UPDATEFILE then Inc(NUpd); + end; + Check((Msgs.Count > 0) and (MsgId(Msgs[0]) = PLI_PLAYERPROPS), + 'burst: the props come first, as in the lab run'); + Check(Props = GChar(PLI_PLAYERPROPS) + + GChar(PLPROP_NICKNAME) + GString('stubstub') + + GChar(PLPROP_COLORS) + GChar(1) + GChar(2) + GChar(3) + GChar(4) + GChar(5) + + GChar(PLPROP_PLANGUAGE) + GString(G.Player.Language) + + GChar(PLPROP_OSTYPE) + GString('win') + + GChar(PLPROP_X2) + GShort(ToPixels2(G.Player.X)) + + GChar(PLPROP_Y2) + GShort(ToPixels2(G.Player.Y)), + 'burst: props nickname, colours, language, win, then X2 and Y2'); + Check(NUpd = 1, 'burst: UPDATEFILE for the head'); + for I := 0 to Msgs.Count - 1 do + Check(MsgId(Msgs[I]) <> PLI_TAMPERCHECK, 'burst: no tamper check'); + finally + Msgs.Free; + Codec.Free; + G.Free; + end; +end; + +{ Walking sends GANI once, then the coordinate that changed as Y2 every + tick, then "idle" (lab-v5-2026-10-30.md, "Movement"). } +procedure TestWalkProps; +var + G: TAdventure; + Codec: TGen5; + Msgs: TStringList; + I, NWalk, NIdle, NY: Integer; +begin + G := LoggedInGame(Codec); + { the built-in tile types belong to the built-in sheet, not to this real + board: walk with no table, as on a board with no arrays.dat } + G.Arrays.LoadFromString(''); + Msgs := TStringList.Create; + try + G.Tick; { the login frame } + ServerReadAll(Codec, G.Client.Sent, Msgs); + G.Client.Sent := ''; + for I := 1 to 8 do + begin + G.Keys[DirDown] := True; + G.Tick; + end; + G.Keys[DirDown] := False; + G.Tick; + G.Tick; + Check(ServerReadAll(Codec, G.Client.Sent, Msgs), 'walk: frames decode'); + NWalk := 0; + NIdle := 0; + NY := 0; + for I := 0 to Msgs.Count - 1 do + if MsgId(Msgs[I]) = PLI_PLAYERPROPS then + begin + if Pos(GChar(PLPROP_GANI) + GString('walk'), Msgs[I]) = 2 then Inc(NWalk); + if Pos(GChar(PLPROP_GANI) + GString('idle'), Msgs[I]) = 2 then Inc(NIdle); + if Pos(GChar(PLPROP_Y2), Msgs[I]) > 0 then Inc(NY); + end; + Check((NWalk = 1) and (NIdle = 1), 'walk: GANI walk once at the start, idle once at the end'); + Check(NY = 8, Format('walk: 8 half-tile steps go out as 8 Y2 props (every tick), got %d', [NY])); + Check(G.Player.Y = 34.5, 'walk: 8 frames down moves 4 tiles'); + finally + Msgs.Free; + Codec.Free; + G.Free; + end; +end; + +procedure TestProps; +var + G: TAdventure; + P: TServerPlayer; + R: TGReader; +begin + G := TAdventure.Create; + try + P := G.FindOther(7, True); + R := TGReader.Create(GChar(PLPROP_NICKNAME) + GString('bob') + + GChar(PLPROP_GANI) + GString('walk') + GChar(PLPROP_SPRITE) + GChar(DirLeft) + + GChar(PLPROP_X) + GChar(40) + GChar(PLPROP_OSTYPE) + GString('wind') + + GChar(PLPROP_TEXTCODEPAGE) + GInt3(1252) + + GChar(PLPROP_MAXPOWER) + GChar(6) + GChar(PLPROP_Y) + GChar(50)); + try + P.ApplyProps(R, True, 0); + finally + R.Free; + end; + Check((P.Nickname = 'bob') and (P.X = 20) and (P.Y = 0) and (P.OsType = 'wind') and + (P.CodePage = 1252), 'others: 75 and 76 parse; the stream stops at MAXPOWER'); + Check((P.AniName = 'walk') and (P.FixedStep = -1) and (P.Dir = DirLeft), + 'others: the pose comes from the GANI prop and runs with time'); + R := TGReader.Create(GChar(PLPROP_GMAPLEVELX) + GChar(3) + GChar(PLPROP_Z) + GChar(52) + + GChar(PLPROP_JOINLEAVELVL) + GChar(0)); + try + P.ApplyProps(R, True, 0); + finally + R.Free; + end; + Check((P.GmapX = 3) and (P.Z = 2) and P.Gone, 'others: GMAPLEVELX, Z and a level leave'); + R := TGReader.Create(GChar(PLPROP_X) + GChar(40) + GChar(PLPROP_JOINLEAVELVL) + GChar(1) + + GChar(PLPROP_Y) + GChar(50)); + try + G.Player.ApplyProps(R, False, 0); + finally + R.Free; + end; + Check((G.Player.X = 20) and (G.Player.Y <> 25), 'self: the own stream stops at 50'); + R := TGReader.Create(GChar(PLPROP_GATTRIB30) + GString('a') + GChar(PLPROP_OSTYPE) + + GString('wind') + GChar(PLPROP_Y) + GChar(50)); + try + G.Player.ApplyProps(R, False, 0); + finally + R.Free; + end; + Check((G.Player.Y = 25) and (G.Player.OsType = 'wind'), 'self: the own stream takes 74, 75 and Y'); + R := TGReader.Create(GChar(PLPROP_X2) + GShort(ToPixels2(12.5)) + GChar(PLPROP_Y2) + + GShort(ToPixels2(-1.0)) + GChar(77) + GChar(1) + GChar(PLPROP_X) + GChar(2)); + try + G.Player.ApplyProps(R, False, 0); + finally + R.Free; + end; + Check((G.Player.X = 12.5) and (G.Player.Y = -1) and (ToPixels2(12.5) = 400) and + (ToPixels2(-1) = 33), 'X2 / Y2: pixels x 2, low bit the sign; the stream stops at 77'); + finally + G.Free; + end; +end; + +procedure WriteText(const FileName, Text: string); +var + F: TFileStream; +begin + F := TFileStream.Create(FileName, fmCreate); + try + if Text <> '' then F.WriteBuffer(Text[1], Length(Text)); + finally + F.Free; + end; +end; + +function BE(V: Integer): string; +begin + Result := Chr((V shr 24) and $FF) + Chr((V shr 16) and $FF) + Chr((V shr 8) and $FF) + Chr(V and $FF); +end; + +function MakeArrays(const Free: array of Integer): string; +var + I: Integer; +begin + Result := BE(Length(Free)); + for I := 0 to High(Free) do Result := Result + BE(Free[I]); + for I := 1 to 24 do Result := Result + BE(0); +end; + +{ The walking rule (as 2.05's; run-222d shows the same half-tile steps). } +procedure TestWalking; +var + G: TAdventure; + I: Integer; +begin + G := TAdventure.Create; + try + G.Arrays.LoadFromString(MakeArrays([0])); + for I := 0 to BoardSize - 1 do G.Level.Tiles[I] := 0; + for I := 0 to 63 do G.Level.Tiles[I + 20 * 64] := 1; + G.Player.X := 9.5; + G.Player.Y := 10; + G.WalkStep(DirRight); + Check((G.Player.X = 10) and (G.Player.Dir = DirRight), 'walk: a free step is half a tile'); + for I := 1 to 40 do G.WalkStep(DirDown); + Check(G.Player.Y = 17, 'walk: stops with the body on the wall''s tile line'); + finally + G.Free; + end; +end; + +{ Links offline, and online: LEVELWARP the first time, LEVELWARPMOD with + the mod time once the level is held, each followed by the tamper check + in the same frame. } +procedure TestLinks; +var + G: TAdventure; + Codec, SrvOut: TGen5; + Dir: string; + Msgs: TStringList; + I: Integer; + Plain, Board: string; +begin + Dir := IncludeTrailingPathDelimiter(GetTempDir(False)) + 'g222links' + PathDelim; + ForceDirectories(Dir); + WriteText(Dir + 'a.nw', 'GLEVNW01'#10'LINK b.nw 63 0 1 64 0 playery'#10); + WriteText(Dir + 'b.nw', 'GLEVNW01'#10'LINK a.nw 0 10 1 10 61 12.5'#10); + G := TAdventure.Create; + try + G.Arrays.LoadFromString(MakeArrays([0])); + Check(G.LoadLevelFile(Dir + 'a.nw'), 'links: level a loads'); + G.Player.X := 59; + G.Player.Y := 20; + for I := 1 to 6 do + if G.Level.Name = 'a.nw' then + begin + G.Keys[DirRight] := True; + G.Tick; + end; + Check((G.Level.Name = 'b.nw') and (G.Player.X = 0) and (G.Player.Y = 20), + 'links: offline, the edge link loads b.nw at x 0, keeping y'); + finally + G.Free; + DeleteFile(Dir + 'a.nw'); + DeleteFile(Dir + 'b.nw'); + RemoveDir(Dir); + end; + + G := LoggedInGame(Codec); + SrvOut := TGen5.Create(CaptureKey); + Msgs := TStringList.Create; + try + { the server's out iterator: in step after the 8 captured frames } + for I := 0 to High(CaptureSC) do + begin + Plain := Copy(Unhex(CaptureSC[I]), 2, MaxInt); + SrvOut.Apply(Plain, Ord(Unhex(CaptureSC[I])[1])); + end; + G.Tick; + ServerReadAll(Codec, G.Client.Sent, Msgs); + G.Client.Sent := ''; + SetLength(G.Level.Links, 1); + G.Level.Links[0].Dest := 'b.nw'; + G.Level.Links[0].X := 0; G.Level.Links[0].Y := 0; + G.Level.Links[0].W := 64; G.Level.Links[0].H := 64; + G.Level.Links[0].NewX := '10'; G.Level.Links[0].NewY := '11'; + Check(G.FollowLink(0), 'links: online, a link asks the server'); + G.Client.Flush; + ServerReadAll(Codec, G.Client.Sent, Msgs); + Check((Msgs.Count >= 1) and (Msgs[0] = GChar(PLI_LEVELWARP) + GChar(20) + GChar(22) + 'b.nw') and + (Msgs.Count = 1), + 'links: LEVELWARP x*2, y*2, level, and no tamper check'); + { the server's answer: level name, board, mod time } + SetLength(Board, 8192); + for I := 1 to 8192 do Board[I] := #0; + G.Client.FeedRaw(ServerFrame(SrvOut, GChar(PLO_LEVELNAME) + 'b.nw'#10 + + GChar(PLO_RAWDATA) + GInt3(8194) + #10 + GChar(PLO_BOARDPACKET) + Board + #10 + + GChar(PLO_LEVELMODTIME) + GInt5(1234567) + #10)); + Check((G.Level.Name = 'b.nw') and G.BoardLoaded and (G.Player.X = 10) and + (G.Player.Y = 11) and (G.WarpCount = 1), 'links: the warp completes when b.nw arrives'); + Check(G.CachedLevel('b.nw', False).HasModTime and + (G.CachedLevel('b.nw', False).ModTime = 1234567), 'links: the mod time is kept'); + { back to the start level (no mod time for it in this test: LEVELWARP), + then to b.nw again: LEVELWARPMOD } + G.CachedLevel('onlinestartlocal.nw', False).HasModTime := False; + G.Client.Sent := ''; + SetLength(G.Level.Links, 1); + G.Level.Links[0].Dest := 'onlinestartlocal.nw'; + G.Level.Links[0].X := 0; G.Level.Links[0].Y := 0; + G.Level.Links[0].W := 64; G.Level.Links[0].H := 64; + G.Level.Links[0].NewX := '1'; G.Level.Links[0].NewY := '1'; + G.FollowLink(0); + G.Client.Flush; + ServerReadAll(Codec, G.Client.Sent, Msgs); + Check((Msgs.Count >= 1) and (MsgId(Msgs[0]) = PLI_LEVELWARP), + 'links: a level without a mod time goes as LEVELWARP'); + G.Client.FeedRaw(ServerFrame(SrvOut, GChar(PLO_LEVELNAME) + 'onlinestartlocal.nw'#10)); + SetLength(G.Level.Links, 1); + G.Level.Links[0].Dest := 'b.nw'; + G.Level.Links[0].X := 0; G.Level.Links[0].Y := 0; + G.Level.Links[0].W := 64; G.Level.Links[0].H := 64; + G.Level.Links[0].NewX := '3'; G.Level.Links[0].NewY := '4'; + G.Client.Sent := ''; + G.FollowLink(0); + G.Client.Flush; + ServerReadAll(Codec, G.Client.Sent, Msgs); + Check((Msgs.Count = 1) and (Msgs[0] = GChar(PLI_LEVELWARPMOD) + GInt5(1234567) + + GChar(6) + GChar(8) + 'b.nw'), + 'links: a held level goes as LEVELWARPMOD with its mod time, no 39'); + { a cached answer has no board: the level stays drawn from the cache } + G.Client.FeedRaw(ServerFrame(SrvOut, GChar(PLO_LEVELNAME) + 'b.nw'#10 + + GChar(PLO_SETACTIVELEVEL) + 'b.nw'#10)); + Check((G.Level.Name = 'b.nw') and G.BoardLoaded and (G.Player.X = 3), + 'links: a cached answer (no board) still lands the player in b.nw'); + finally + Msgs.Free; + SrvOut.Free; + Codec.Free; + G.Free; + end; +end; + +{ A 3x2 gmap: login with PLAYERWARP2, the .gmap by WANTFILE / FILE, the + neighbours by ADJACENTLEVEL, and a walk across the east edge. } +procedure TestGmap; +const + GmapText = 'GRMAP001'#13#10'WIDTH 3'#13#10'HEIGHT 2'#13#10'LEVELNAMES'#13#10 + + '"g_0_0.nw","g_1_0.nw","g_2_0.nw"'#13#10'"g_0_1.nw","g_1_1.nw","g_2_1.nw"'#13#10 + + 'LEVELNAMESEND'#13#10; +var + G: TAdventure; + Codec, SrvOut: TGen5; + M: TGmap; + Msgs: TStringList; + I, NAdj: Integer; + Plain, Board, F: string; + CX, CY: Integer; + Got39, GotCell: Boolean; +begin + M := TGmap.Create; + try + Check(M.LoadFromString(GmapText) and (M.Width = 3) and (M.Height = 2) and + (M.CellName(2, 1) = 'g_2_1.nw') and (M.CellName(3, 0) = ''), + 'gmap: GRMAP001 WIDTH, HEIGHT and LEVELNAMES'); + Check(M.FindCell('G_1_1.NW', CX, CY) and (CX = 1) and (CY = 1), 'gmap: a level''s cell'); + Check(not M.LoadFromString('GRMAP002'#10'WIDTH 1'), 'gmap: a wrong signature is rejected'); + finally + M.Free; + end; + + G := LoggedInGame(Codec); + SrvOut := TGen5.Create(CaptureKey); + Msgs := TStringList.Create; + try + G.Arrays.LoadFromString(MakeArrays([0])); + for I := 0 to High(CaptureSC) do + begin + Plain := Copy(Unhex(CaptureSC[I]), 2, MaxInt); + SrvOut.Apply(Plain, Ord(Unhex(CaptureSC[I])[1])); + end; + G.Tick; + Drain(G, Codec); + SetLength(Board, 8192); + for I := 1 to 8192 do Board[I] := #0; + { the server warps the player onto the gmap, cell 0,0 at x 60 } + G.Client.FeedRaw(ServerFrame(SrvOut, GChar(PLO_PLAYERWARP2) + GChar(120) + GChar(60) + + GChar(50) + GChar(0) + GChar(0) + 'g.gmap'#10 + + GChar(PLO_LEVELNAME) + 'g_0_0.nw'#10 + GChar(PLO_RAWDATA) + GInt3(8194) + #10 + + GChar(PLO_BOARDPACKET) + Board + #10 + GChar(PLO_LEVELMODTIME) + GInt5(99) + #10 + + GChar(PLO_LEVELNAME) + 'g.gmap'#10 + GChar(PLO_SETACTIVELEVEL) + 'g.gmap'#10)); + G.Client.Flush; + ServerReadAll(Codec, G.Client.Sent, Msgs); + Check((G.GmapName = 'g.gmap') and (G.Gmap = nil) and (Msgs.Count >= 1) and + (Msgs[0] = GChar(PLI_WANTFILE) + 'g.gmap'), 'gmap: an unknown .gmap is asked for with WANTFILE'); + Check((G.Level.Name = 'g_0_0.nw') or (G.Level.Name = ''), 'gmap: the player''s level is the cell''s'); + { the file arrives: i5 mod time, name, data } + G.Client.Sent := ''; + F := GInt5(1) + GString('g.gmap') + GmapText; + G.Client.FeedRaw(ServerFrame(SrvOut, GChar(PLO_RAWDATA) + GInt3(Length(F) + 2) + #10 + + GChar(PLO_FILE) + F + #10)); + G.Client.Flush; + ServerReadAll(Codec, G.Client.Sent, Msgs); + NAdj := 0; + for I := 0 to Msgs.Count - 1 do + if MsgId(Msgs[I]) = PLI_ADJACENTLEVEL then Inc(NAdj); + Check((G.Gmap <> nil) and (NAdj = 3) and (Msgs[0] = GChar(PLI_ADJACENTLEVEL) + GInt5(0) + 'g_0_1.nw'), + 'gmap: the 3 neighbours of cell 0,0 are asked for, mod time 0'); + { neighbour data goes to the neighbour, not the player's level } + G.Client.FeedRaw(ServerFrame(SrvOut, GChar(PLO_LEVELNAME) + 'g_1_0.nw'#10 + + GChar(PLO_RAWDATA) + GInt3(8194) + #10 + GChar(PLO_BOARDPACKET) + Board + #10 + + GChar(PLO_LEVELNAME) + 'g.gmap'#10)); + Check((G.Level.Name = 'g_0_0.nw') and G.CachedLevel('g_1_0.nw', False).HasBoard, + 'gmap: a neighbour''s board is kept apart from the current level'); + Check(G.WorldTile(64 + 5, 3) = 0, 'gmap: world tiles come from the neighbour''s board'); + { walk east across x 64 } + G.Client.Sent := ''; + for I := 1 to 12 do + begin + G.Keys[DirRight] := True; + G.Tick; + end; + ServerReadAll(Codec, G.Client.Sent, Msgs); + Got39 := False; + GotCell := False; + for I := 0 to Msgs.Count - 1 do + begin + if MsgId(Msgs[I]) = PLI_TAMPERCHECK then Got39 := True; + if (MsgId(Msgs[I]) = PLI_PLAYERPROPS) and + (Pos(GChar(PLPROP_GMAPLEVELX) + GChar(1), Msgs[I]) > 0) then GotCell := True; + end; + Check((G.Player.GmapX = 1) and (G.Player.X < 10) and (G.Level.Name = 'g_1_0.nw') and + (G.EdgeCrossings = 1), 'gmap: walking east past x 64 moves into cell 1,0'); + Check(not Got39 and GotCell, 'gmap: the crossing sends props with GMAPLEVELX = 1 and no 39'); + finally + Msgs.Free; + SrvOut.Free; + Codec.Free; + G.Free; + end; +end; + +{ The lab saw 5.x send 24 about every 5 s, but not its payload or what + starts it; the rebuild sends none yet. } +procedure TestShowImg; +var + G: TAdventure; + Codec, SrvOut: TGen5; + Msgs: TStringList; + I, N: Integer; + Plain: string; +begin + G := LoggedInGame(Codec); + SrvOut := TGen5.Create(CaptureKey); + Msgs := TStringList.Create; + try + for I := 0 to High(CaptureSC) do + begin + Plain := Copy(Unhex(CaptureSC[I]), 2, MaxInt); + SrvOut.Apply(Plain, Ord(Unhex(CaptureSC[I])[1])); + end; + G.ClockMs := 1000; + G.Tick; + G.Client.FeedRaw(ServerFrame(SrvOut, GChar(PLO_OTHERPLPROPS) + GShort(2) + + GChar(PLPROP_NICKNAME) + GString('other') + #10)); + Drain(G, Codec); + for I := 1 to 220 do + begin + G.ClockMs := 1000 + I * 50; + G.Tick; + end; + ServerReadAll(Codec, G.Client.Sent, Msgs); + N := 0; + for I := 0 to Msgs.Count - 1 do + if Msgs[I] = GChar(PLI_SHOWIMG) + GChar(9) then Inc(N); + Check(N = 0, Format('24: none over TCP in 11 s with another player in the level, got %d', [N])); + finally + Msgs.Free; + SrvOut.Free; + Codec.Free; + G.Free; + end; +end; + +{ ---- fuzzing the receive path ---- } + +const + FuzzIds: array[0..31] of Integer = (PLO_LEVELLINK, PLO_LEVELCHEST, PLO_LEVELSIGN, + PLO_LEVELNAME, PLO_OTHERPLPROPS, PLO_PLAYERPROPS, PLO_PLAYERWARP, PLO_WARPFAILED, + PLO_DISCMESSAGE, PLO_SIGNATURE, PLO_NEWWORLDTIME, PLO_STARTMESSAGE, PLO_BOARDPACKET, + PLO_SETACTIVELEVEL, PLO_TOALL, PLO_LEVELBOARD, PLO_BOARDMODIFY, PLO_NPCPROPS, + PLO_BADDYPROPS, PLO_LEVELMODTIME, PLO_FILE, PLO_RAWDATA, PLO_PLAYERWARP2, + PLO_BOARDMODIFY2, PLO_SERVERWARP, PLO_LARGEFILESTART, PLO_LARGEFILEEND, + PLO_FREEZEPLAYER2, PLO_UNFREEZEPLAYER, PLO_SHOWIMGPLAYER, PLO_GHOSTICON, PLO_LARGEFILESTART); + +function RandomBytes(N: Integer; Printable: Boolean): string; +var + I: Integer; +begin + SetLength(Result, N); + for I := 1 to N do + if Printable then Result[I] := Chr(32 + Random(96)) + else Result[I] := Chr(Random(256)); +end; + +function RandomProps: string; +var + I, N: Integer; +begin + Result := ''; + N := Random(12); + for I := 1 to N do + begin + Result := Result + GChar(Random(80)); + case Random(4) of + 0: Result := Result + GChar(Random(224) - 32); + 1: Result := Result + GString(RandomBytes(Random(12), True)); + 2: Result := Result + RandomBytes(Random(6), False); + else + Result := Result + Chr(Random(256)); + end; + end; + if (Result <> '') and (Random(3) = 0) then + SetLength(Result, Random(Length(Result))); +end; + +function RandomMessage(out Id: Integer): string; +const + Names: array[0..4] of string = ('g.gmap', 'a.nw', 'g_0_0.nw', 'x.gmap', ''); +begin + if Random(5) = 0 then Id := Random(256) else Id := FuzzIds[Random(Length(FuzzIds))]; + case Id of + PLO_PLAYERPROPS: Result := RandomProps; + PLO_OTHERPLPROPS: Result := GShort(Random(8)) + RandomProps; + PLO_BOARDPACKET: + case Random(3) of + 0: Result := RandomBytes(8192, False); + 1: Result := RandomBytes(Random(9000), False); + else + Result := ''; + end; + PLO_LEVELNAME, PLO_SETACTIVELEVEL: Result := Names[Random(5)]; + PLO_PLAYERWARP2: + Result := RandomBytes(Random(6), False) + Names[Random(5)]; + PLO_FILE: + if Random(2) = 0 then + Result := GInt5(Random(1000)) + GString('g.gmap') + 'GRMAP001'#10'WIDTH ' + + IntToStr(Random(300) - 10) + #10'HEIGHT ' + IntToStr(Random(5)) + + #10'LEVELNAMES'#10 + RandomBytes(Random(40), True) + #10'LEVELNAMESEND'#10 + else + Result := RandomBytes(Random(60), False); + PLO_SERVERWARP: + { never four good fields: the fuzzer must not open connections } + Result := RandomBytes(Random(10), True) + ',' + RandomBytes(Random(10), True); + PLO_LEVELLINK: + Result := RandomBytes(Random(10), True) + ' ' + IntToStr(Random(80) - 8) + ' ' + + IntToStr(Random(80) - 8) + ' ' + IntToStr(Random(70)) + ' ' + IntToStr(Random(70)) + + ' ' + RandomBytes(Random(5), True) + ' ' + RandomBytes(Random(5), True); + else + Result := RandomBytes(Random(48), Random(2) = 0); + end; +end; + +procedure TestFuzz; +var + G: TAdventure; + I, J, Id, Raised: Integer; + Data, Plain, LastErr: string; + SrvOut: TGen5; +begin + RandSeed := 222; + Raised := 0; + LastErr := ''; + G := TAdventure.Create; + SrvOut := TGen5.Create(9); + try + G.Arrays.LoadFromString(MakeArrays([0])); + G.UseWallClock := False; + if GetEnvironmentVariable('GRAAL500_DATA') <> '' then + G.UseInstall(GetEnvironmentVariable('GRAAL500_DATA')); + G.Client.StartOffline(9); + G.Client.Sink := True; + for I := 1 to 20000 do + begin + Data := RandomMessage(Id); + try + G.Receive(Id, Data); + if I mod 50 = 0 then + begin + for J := 0 to 3 do G.Keys[J] := Random(2) = 0; + G.ClockMs := G.ClockMs + 50; + G.Tick; + G.Client.Sent := ''; + G.Client.Sink := True; + end; + except + on E: Exception do + begin + Inc(Raised); + if LastErr = '' then + begin + LastErr := Format('id %d, %d bytes: %s: %s', [Id, Length(Data), E.ClassName, E.Message]); +{$IFDEF FPC} + DumpExceptionBackTrace(Output); +{$ENDIF} + end; + end; + end; + end; + if LastErr <> '' then WriteLn(' first: ', LastErr); + Check(Raised = 0, Format('fuzz: 20000 random messages, %d raised', [Raised])); + + { gen-5 frames around random messages, and raw garbage; a bad frame + drops the link, so the codec is started again for the next one } + Raised := 0; + LastErr := ''; + for I := 1 to 3000 do + begin + try + if not G.Client.Connected then + begin + G.Client.StartOffline(9); + G.Client.Sink := True; + SrvOut.Iterator := CipherSeed; + end; + if Random(4) = 0 then + G.Client.FeedRaw(RandomBytes(Random(64), False)) + else + begin + Plain := ''; + for J := 1 to 1 + Random(6) do + begin + Data := RandomMessage(Id); + if Random(8) = 0 then + Plain := Plain + Chr(PLO_RAWDATA + 32) + GInt3(Length(Data) + 2) + #10 + + Chr((Id + 32) and $FF) + Data + #10 + else + Plain := Plain + Chr((Id + 32) and $FF) + StringReplace(Data, #10, ' ', + [rfReplaceAll]) + #10; + end; + Data := ServerFrame(SrvOut, Plain); + J := Random(Length(Data) + 1); + G.Client.FeedRaw(Copy(Data, 1, J)); + G.Client.FeedRaw(Copy(Data, J + 1, MaxInt)); + end; + if I mod 20 = 0 then + begin + G.Tick; + G.Client.Sent := ''; + end; + except + on E: Exception do + begin + Inc(Raised); + if LastErr = '' then + begin + LastErr := E.ClassName + ': ' + E.Message; +{$IFDEF FPC} + DumpExceptionBackTrace(Output); +{$ENDIF} + end; + end; + end; + end; + if LastErr <> '' then WriteLn(' first: ', LastErr); + Check(Raised = 0, Format('fuzz: 3000 random gen-5 frames, %d raised', [Raised])); + finally + SrvOut.Free; + G.Free; + end; +end; + +procedure TestReceiveLimits; +var + G: TAdventure; + I: Integer; + Plain: string; + T0: TDateTime; + SrvOut: TGen5; +begin + G := TAdventure.Create; + SrvOut := TGen5.Create(3); + try + G.Client.StartOffline(3); + Plain := ''; + for I := 1 to 20000 do Plain := Plain + Chr(PLO_TOALL + 32) + 'x' + #10; + T0 := Now; + G.Client.FeedRaw(ServerFrame(SrvOut, Plain)); + Check(G.Handled[PLO_TOALL] = 20000, 'receive: 20000 messages in one bz2 frame'); + Check((Now - T0) * 86400 < 2, 'receive: a big burst takes well under 2 s'); + G.Client.FeedRaw(ServerFrame(SrvOut, StringOfChar('a', InPendingMax + 1))); + Check(Pos('unfinished', G.Client.LastError) > 0, + 'receive: an unfinished message past the limit drops the link'); + G.Client.StartOffline(3); + SrvOut.Iterator := CipherSeed; + G.Client.LastError := ''; + G.Client.FeedRaw(#0#6#4'xxxxx'); + Check(Pos('bad frame', G.Client.LastError) > 0, 'receive: a bad zlib frame drops the link'); + G.Client.StartOffline(3); + G.Client.LastError := ''; + G.Client.FeedRaw(#0#4#7'abc'); + Check(Pos('bad frame', G.Client.LastError) > 0, 'receive: an unknown compression byte drops the link'); + G.Client.StartOffline(3); + SrvOut.Iterator := CipherSeed; + G.Client.FeedRaw(ServerFrame(SrvOut, Chr(PLO_TOALL + 32) + 'y' + #10)); + Check(G.Handled[PLO_TOALL] = 20001, 'receive: buffers are clean after a dropped link'); + finally + SrvOut.Free; + G.Free; + end; +end; + +{ The Login lobby: the first server is Login, where no characters are + drawn; 182 is answered with 44; a 178 "x,name,host,port" is split on + commas only and its name ends Login mode (lab-v5-2026-10-30.md). } +procedure TestLobby; +var + G: TAdventure; + Codec, SrvOut: TGen5; + Msgs: TStringList; + I, N: Integer; + Plain: string; +begin + G := LoggedInGame(Codec); + SrvOut := TGen5.Create(CaptureKey); + Msgs := TStringList.Create; + try + for I := 0 to High(CaptureSC) do + begin + Plain := Copy(Unhex(CaptureSC[I]), 2, MaxInt); + SrvOut.Apply(Plain, Ord(Unhex(CaptureSC[I])[1])); + end; + Check((G.ServerName = 'Login') and G.LoginMode, 'lobby: the first server is Login, in Login mode'); + G.ServerName := 'LOGIN2'; + Check(G.LoginMode, 'lobby: any name that starts with login, in any case'); + G.ServerName := 'Classic'; + Check(not G.LoginMode, 'lobby: another name plays'); + G.ServerName := 'Login'; + G.Tick; + Drain(G, Codec); + G.Client.FeedRaw(ServerFrame(SrvOut, GChar(PLO_LISTPROCESSES) + #10)); + G.Client.Flush; + ServerReadAll(Codec, G.Client.Sent, Msgs); + G.Client.Sent := ''; + N := 0; + for I := 0 to Msgs.Count - 1 do + if Msgs[I] = GChar(PLI_PROCESSLIST) + 'Login' then Inc(N); + Check(N = 1, '182: answered with 44 naming only the game window'); + G.Client.FeedRaw(ServerFrame(SrvOut, GChar(PLO_SERVERWARP) + '0,Lab Server,127.0.0.1' + #10)); + Check((G.ServerWarps = 0) and (G.ServerName = 'Login'), '178: three fields are ignored'); + G.Client.FeedRaw(ServerFrame(SrvOut, GChar(PLO_SERVERWARP) + '0,Lab Server,127.0.0.1,1' + #10)); + Check((G.ServerWarps = 1) and (G.ServerName = 'Lab Server') and not G.LoginMode and + not G.LoggedIn, '178: split on commas only; the name with its space ends Login mode'); + finally + Msgs.Free; + SrvOut.Free; + Codec.Free; + G.Free; + end; +end; + +procedure TestBoardModify; +var + G: TAdventure; +begin + G := TAdventure.Create; + try + G.Receive(PLO_BOARDMODIFY, GChar(2) + GChar(3) + GChar(2) + GChar(1) + GShort(77) + GShort(78)); + Check((G.Level.Tile(2, 3) = 77) and (G.Level.Tile(3, 3) = 78), 'BOARDMODIFY: a 2x1 patch'); + G.Receive(PLO_BOARDMODIFY, GChar(2) + GChar(3) + GChar(2) + GChar(1) + GShort(5)); + Check(G.Level.Tile(2, 3) = 77, 'BOARDMODIFY: a short payload is dropped'); + G.Receive(PLO_BOARDMODIFY2, GChar(0) + GChar(0) + GChar(62) + GChar(63) + GChar(4) + + GChar(1) + GShort(9) + GShort(9) + GShort(9) + GShort(9) + 'pad'); + Check(G.Level.Tile(63, 63) = 9, 'BOARDMODIFY2: tiles past the board edge are clipped'); + finally + G.Free; + end; +end; + +{ The built-in defaults: a game with nothing next to it still has a tile + sheet, the starter level and the walking gani. } +procedure TestBuiltins; +var + G: TAdventure; +begin + G := TAdventure.Create; + try + G.Headless := True; + Check(G.SheetBuiltin and (G.Sheet <> nil) and (G.Sheet.Width > 0), + 'built-in: the default tile sheet'); + Check(G.LoadLevelFile('start.nw') and (Length(G.Level.Links) > 0), + 'built-in: start.nw loads with no install'); + Check(G.Assets.Ani('walk') <> nil, 'built-in: walk gani'); + { the tutorial's addtiledef, read from its NPC script } + SetLength(G.Level.NPCs, 1); + G.Level.NPCs[0].Script := 'if (playerenters) {'#10 + + ' addtiledef picso.png,offlinetutorial,1;'#10' loadmap x;'#10'}'; + G.NoteTileDefs(G.Level); + Check((G.TileDefs.Count = 1) and (G.TileDefs[0] = 'offlinetutorial'#9'picso.png'), + 'addtiledef: image and prefix read from the level script'); + Check(G.TileSheetFor('offlinetutorial_a-1.graal') = G.Sheet, + 'addtiledef: a missing image keeps pics1'); + Check(G.TileSheetFor('start.nw') = G.Sheet, 'addtiledef: other levels keep pics1'); + finally + G.Free; + end; +end; + +begin + TestGTypes; + TestBzip2; + TestGen5Capture; + TestLogin; + TestListServer; + TestBuiltins; + TestLoginBurst; + TestWalkProps; + TestProps; + TestWalking; + TestLinks; + TestGmap; + TestShowImg; + TestLobby; + TestBoardModify; + TestFuzz; + TestReceiveLimits; + WriteLn(Format('%d passed, %d failed, %d skipped', [Passed, Failed, Skipped])); + if Failed > 0 then Halt(1); +end.