Commit 698b99b

Nick Faro committed on
Fur import
commit 698b99bb7a9cac6f446113b16c72fa4abb6f37db parent 1bf039f
4 changed files +1743−2
Addedsrc/furimport.pas +1697−0
@@ -0,0 +1,1697 @@
1 unit FurImport;
2
3 {$mode objfpc}{$H+}
4 {$scopedenums on}
5
6 // Ported from fur2uge (C#, MIT): https://github.com/potatoTeto/fur2uge
7 // Loads a Furnace Tracker .fur file directly into a hUGETracker TSong.
8 // Preserves fur2uge's known limitations: GB module only, 64-row patterns,
9 // 15 instruments/channel type, hardware envelopes only, one effect column.
10
11 interface
12
13 uses
14 Classes, SysUtils, Song, HugeDatatypes, Constants, Utils, fgl;
15
16 type
17 EFurException = class(Exception);
18
19 function LoadSongFromFurStream(Stream: TStream): TSong;
20
21 implementation
22
23 uses
24 zstream, Math;
25
26 const
27 FUR_MAGIC = '-Furnace module-';
28 CHIP_GAME_BOY = $04;
29
30 // fur effect opcodes
31 FX_ARPEGGIO = $00;
32 FX_PORTA_UP = $01;
33 FX_PORTA_DOWN = $02;
34 FX_TONE_PORTA = $03;
35 FX_VIBRATO = $04;
36 FX_HW_PAN = $08;
37 FX_VOLUME_SLIDE = $0A;
38 FX_POSITION_JUMP = $0B;
39 FX_PATTERN_BREAK = $0D;
40 FX_SET_SPEED = $0F;
41 FX_SET_DUTY = $12;
42 FX_SOFTWARE_PAN = $80;
43 FX_NOTE_CUT = $EC;
44 FX_NOTE_DELAY = $ED;
45 FX_EMPTY = $F1;
46
47 // hUGE effect codes (as they appear in TCell.EffectCode)
48 HFX_ARPEGGIO = $0;
49 HFX_PORTA_UP = $1;
50 HFX_PORTA_DOWN = $2;
51 HFX_TONE_PORTA = $3;
52 HFX_VIBRATO = $4;
53 HFX_CALL_ROUTINE = $6;
54 HFX_NOTE_DELAY = $7;
55 HFX_SET_PANNING = $8;
56 HFX_SET_DUTY = $9;
57 HFX_VOLUME_SLIDE = $A;
58 HFX_POSITION_JUMP = $B;
59 HFX_SET_VOL = $C;
60 HFX_PATTERN_BREAK = $D;
61 HFX_NOTE_CUT = $E;
62 HFX_SET_SPEED = $F;
63
64 // fur instrument feature codes
65 FEAT_NAME = 1;
66 FEAT_MACRO = 2;
67 FEAT_GB = 3;
68 FEAT_WS = 4;
69 FEAT_END = 99;
70 FEAT_IGNORE = 0;
71
72 // fur macro codes
73 MC_VOL = 0;
74 MC_ARP = 1;
75 MC_DUTY = 2;
76 MC_WAVE = 3;
77 MC_PITCH = 4;
78 MC_PAN_L = 12;
79
80 type
81 TFurMacro = record
82 Code: Integer;
83 LoopPoint: Byte;
84 Data: array of Integer;
85 end;
86
87 TFurGBHWSeq = record
88 CmdType: Byte;
89 // For SET_SWEEP:
90 SweepSpeed: Byte;
91 SweepDir: Integer;
92 ShiftVal: Byte;
93 end;
94
95 TFurGBInstr = record
96 Present: Boolean;
97 EnvLen: Byte;
98 EnvDir: Integer; // 0 = decrease, 1 = increase
99 EnvVol: Byte;
100 SndLen: Byte;
101 Flags: Byte;
102 HWSeq: array of TFurGBHWSeq;
103 end;
104
105 TFurWSInstr = record
106 Present: Boolean;
107 FirstWave: Integer;
108 Enabled: Boolean;
109 end;
110
111 TFurInstrument = class
112 Name: String;
113 InstFormatVersion: Integer;
114 ID: Integer;
115 GB: TFurGBInstr;
116 WS: TFurWSInstr;
117 Macros: array of TFurMacro;
118 procedure AddMacro(const M: TFurMacro);
119 end;
120
121 TFurInstrumentList = specialize TFPGObjectList<TFurInstrument>;
122
123 TFurCell = record
124 Row: Integer;
125 Note: Integer; // -9999 if absent
126 Instrument: Integer; // -9999 if absent
127 Volume: Integer; // -9999 if absent
128 // Only effect column 0 matters for our purposes; keep up to 8 anyway
129 FxPresent: array[0..7] of Boolean;
130 FxValPresent: array[0..7] of Boolean;
131 Fx: array[0..7] of Byte;
132 FxVal: array[0..7] of Byte;
133 end;
134
135 TFurPattern = class
136 Length: Integer;
137 Rows: array of TFurCell;
138 procedure Add(const C: TFurCell);
139 end;
140
141 TFurPatternMap = specialize TFPGMapObject<Integer, TFurPattern>;
142
143 { TFurReader — parses fur binary and exposes everything ParseSong needs }
144
145 TFurReader = class
146 private
147 FData: TBytes;
148 FPos: Int64;
149 FVersion: Integer;
150
151 // Module info
152 FSongName: String;
153 FAuthor: String;
154 FSongComment: String;
155
156 // Song 0 (we only care about song 0; fur subsongs are ignored)
157 FTimeBase, FSpeed1, FHighlightA: Byte;
158 FTicksPerSecond: Single;
159 FPatternLen: Integer;
160 FOrdersLen: Integer;
161 FVirtualTempoNum, FVirtualTempoDen: Word;
162 FSpeedPatternLen: Integer;
163 FSpeedPattern: array[0..15] of Byte;
164
165 FInstrumentCount, FWavetableCount, FSampleCount: Integer;
166 FPatternCountGlobal: Integer;
167 FTotalChanCount: Integer;
168
169 FInstrumentPointers, FWavetablePointers, FSamplePointers, FPatternPointers:
170 array of Integer;
171
172 // orders[chan, row]
173 FOrderTable: array of array of Integer;
174
175 FInstruments: TFurInstrumentList;
176 // Waveforms as raw 32-byte arrays of 4-bit values
177 FWaveforms: array of TBytes;
178
179 // Patterns per channel, keyed by pattern index
180 FPatterns: array[0..3] of TFurPatternMap;
181
182 function ReadU8: Byte;
183 function ReadU16: Word;
184 function ReadU32: Cardinal;
185 function ReadI32: Integer;
186 function ReadF32: Single;
187 function ReadBytes(Count: Integer): TBytes;
188 function ReadCString: String;
189 procedure Seek(Offset: Int64);
190 procedure Skip(Count: Integer);
191
192 procedure ParseHeader;
193 procedure ParseSongInfo; // Old INFO-block layout (<v200)
194 procedure ParseInfo2; // New INF2-block layout (v200+)
195 procedure ParseSng2(Offset: Integer);
196 procedure ParseInstruments;
197 procedure ParseWavetables;
198 procedure ParsePatterns;
199 public
200 constructor Create(RawBytes: TBytes);
201 destructor Destroy; override;
202
203 procedure Parse;
204
205 property Version: Integer read FVersion;
206 property SongName: String read FSongName;
207 property Author: String read FAuthor;
208 property SongComment: String read FSongComment;
209 property PatternLen: Integer read FPatternLen;
210 property OrdersLen: Integer read FOrdersLen;
211 property TimeBase: Byte read FTimeBase;
212 property Speed1: Byte read FSpeed1;
213 property HighlightA: Byte read FHighlightA;
214 property TicksPerSecond: Single read FTicksPerSecond;
215 property VirtualTempoNum: Word read FVirtualTempoNum;
216 property VirtualTempoDen: Word read FVirtualTempoDen;
217 property SpeedPatternLen: Integer read FSpeedPatternLen;
218 property InstrumentCount: Integer read FInstrumentCount;
219 property WavetableCount: Integer read FWavetableCount;
220 property TotalChanCount: Integer read FTotalChanCount;
221 property Instruments: TFurInstrumentList read FInstruments;
222 function OrderAt(Chan, Row: Integer): Integer;
223
224 function SpeedPatternValue(I: Integer): Byte;
225 function Waveform(I: Integer): TBytes;
226 function GetPattern(Chan, Index: Integer): TFurPattern;
227 end;
228
229 { TFurInstrument }
230
231 procedure TFurInstrument.AddMacro(const M: TFurMacro);
232 begin
233 SetLength(Macros, System.Length(Macros) + 1);
234 Macros[System.Length(Macros) - 1] := M;
235 end;
236
237 { TFurPattern }
238
239 procedure TFurPattern.Add(const C: TFurCell);
240 begin
241 SetLength(Rows, System.Length(Rows) + 1);
242 Rows[System.Length(Rows) - 1] := C;
243 end;
244
245 { TFurReader }
246
247 constructor TFurReader.Create(RawBytes: TBytes);
248 var
249 I: Integer;
250 begin
251 inherited Create;
252 FData := RawBytes;
253 FPos := 0;
254 FInstruments := TFurInstrumentList.Create(True);
255 for I := 0 to 3 do
256 FPatterns[I] := TFurPatternMap.Create(True);
257 end;
258
259 destructor TFurReader.Destroy;
260 var
261 I: Integer;
262 begin
263 FInstruments.Free;
264 for I := 0 to 3 do
265 FPatterns[I].Free;
266 inherited;
267 end;
268
269 function TFurReader.ReadU8: Byte;
270 begin
271 if FPos >= Length(FData) then
272 raise EFurException.Create('Unexpected EOF while parsing .fur');
273 Result := FData[FPos];
274 Inc(FPos);
275 end;
276
277 function TFurReader.ReadU16: Word;
278 begin
279 Result := ReadU8 or (ReadU8 shl 8);
280 end;
281
282 function TFurReader.ReadU32: Cardinal;
283 begin
284 Result := Cardinal(ReadU8)
285 or (Cardinal(ReadU8) shl 8)
286 or (Cardinal(ReadU8) shl 16)
287 or (Cardinal(ReadU8) shl 24);
288 end;
289
290 function TFurReader.ReadI32: Integer;
291 begin
292 Result := Integer(ReadU32);
293 end;
294
295 function TFurReader.ReadF32: Single;
296 var
297 V: Cardinal;
298 begin
299 V := ReadU32;
300 Move(V, Result, 4);
301 end;
302
303 function TFurReader.ReadBytes(Count: Integer): TBytes;
304 begin
305 if FPos + Count > Length(FData) then
306 raise EFurException.Create('Unexpected EOF while reading block');
307 SetLength(Result, Count);
308 if Count > 0 then
309 Move(FData[FPos], Result[0], Count);
310 Inc(FPos, Count);
311 end;
312
313 function TFurReader.ReadCString: String;
314 var
315 Start: Int64;
316 Len, Safety: Integer;
317 begin
318 Start := FPos;
319 Safety := 5000;
320 while (FPos < Length(FData)) and (FData[FPos] <> 0) do begin
321 Inc(FPos);
322 Dec(Safety);
323 if Safety <= 0 then
324 raise EFurException.Create('String too long or corrupted');
325 end;
326 Len := FPos - Start;
327 SetLength(Result, Len);
328 if Len > 0 then
329 Move(FData[Start], Result[1], Len);
330 if FPos < Length(FData) then
331 Inc(FPos); // skip null
332 end;
333
334 procedure TFurReader.Seek(Offset: Int64);
335 begin
336 if (Offset < 0) or (Offset > Length(FData)) then
337 raise EFurException.CreateFmt('Bad fur offset: %d', [Offset]);
338 FPos := Offset;
339 end;
340
341 procedure TFurReader.Skip(Count: Integer);
342 begin
343 Seek(FPos + Count);
344 end;
345
346 procedure TFurReader.ParseHeader;
347 var
348 MagicBytes: TBytes;
349 Magic: String;
350 begin
351 MagicBytes := ReadBytes(16);
352 SetLength(Magic, 16);
353 Move(MagicBytes[0], Magic[1], 16);
354 if Magic <> FUR_MAGIC then
355 raise EFurException.Create('Not a Furnace module (bad magic).');
356
357 FVersion := ReadU16;
358 ReadU16; // reserved
359 ReadI32; // song info pointer (we're already positioned after header)
360 Skip(8); // reserved2
361
362 if FVersion < 157 then
363 raise EFurException.CreateFmt(
364 'Furnace file uses a legacy format (version %d). Open in a recent ' +
365 'Furnace (0.6+) and re-save — import requires format version 157 or later.',
366 [FVersion]);
367 end;
368
369 procedure TFurReader.ParseInfo2;
370 var
371 InfStart, PayloadEnd: Int64;
372 I, Conn: Integer;
373 ElemType: Byte;
374 ElemCount: Integer;
375 Ptr, K: Integer;
376 ChipID, ChipChanCount: Integer;
377 ChipCount: Integer;
378 Sng2Pointer: Integer;
379 begin
380 // At entry we've already consumed the "INF2" block id. Payload begins
381 // with block size (u32).
382 PayloadEnd := FPos - 4; // will be updated once we read size
383 ReadU32; // block size (we'll walk linearly via element pointers)
384 InfStart := FPos;
385
386 // 8 cstrings: song name, author, system name, album, + 4 JP variants
387 FSongName := ReadCString;
388 FAuthor := ReadCString;
389 ReadCString; // system name
390 ReadCString; // album/category/game
391 ReadCString; // song name JP
392 ReadCString; // author JP
393 ReadCString; // system JP
394 ReadCString; // album JP
395
396 ReadF32; // A-4 tuning
397 ReadU8; // auto-sys-name flag
398 ReadF32; // master volume
399 FTotalChanCount := ReadU16;
400 ChipCount := ReadU16;
401 if ChipCount < 1 then
402 raise EFurException.Create('Furnace module has no sound chips.');
403
404 for I := 0 to ChipCount - 1 do begin
405 ChipID := ReadU16;
406 ChipChanCount := ReadU16;
407 ReadF32; // vol
408 ReadF32; // pan
409 ReadF32; // fr bal
410 if (I = 0) and (ChipID <> CHIP_GAME_BOY) then
411 raise EFurException.CreateFmt(
412 'This .fur uses chip type $%.4x. Only pure Game Boy modules are supported.',
413 [ChipID]);
414 end;
415
416 // Patchbay: u32 count, count × u32 connections, u8 auto flag
417 Conn := ReadI32;
418 Skip(Conn * 4);
419 ReadU8; // auto patchbay flag
420
421 // Song Elements loop until type = 0
422 Sng2Pointer := -1;
423 SetLength(FInstrumentPointers, 0);
424 SetLength(FWavetablePointers, 0);
425 SetLength(FSamplePointers, 0);
426 SetLength(FPatternPointers, 0);
427 FInstrumentCount := 0;
428 FWavetableCount := 0;
429 FSampleCount := 0;
430 FPatternCountGlobal := 0;
431
432 repeat
433 ElemType := ReadU8;
434 if ElemType = 0 then Break;
435 ElemCount := ReadI32;
436
437 case ElemType of
438 $01: begin // SNG2 (songs)
439 for K := 0 to ElemCount - 1 do begin
440 Ptr := ReadI32;
441 if (Sng2Pointer = -1) and (Ptr <> 0) then
442 Sng2Pointer := Ptr;
443 end;
444 end;
445 $04: begin // INS2
446 for K := 0 to ElemCount - 1 do begin
447 Ptr := ReadI32;
448 if Ptr <> 0 then begin
449 SetLength(FInstrumentPointers, FInstrumentCount + 1);
450 FInstrumentPointers[FInstrumentCount] := Ptr;
451 Inc(FInstrumentCount);
452 end;
453 end;
454 end;
455 $05: begin // WAVE
456 for K := 0 to ElemCount - 1 do begin
457 Ptr := ReadI32;
458 if Ptr <> 0 then begin
459 SetLength(FWavetablePointers, FWavetableCount + 1);
460 FWavetablePointers[FWavetableCount] := Ptr;
461 Inc(FWavetableCount);
462 end;
463 end;
464 end;
465 $06: begin // SMP2
466 for K := 0 to ElemCount - 1 do begin
467 Ptr := ReadI32;
468 if Ptr <> 0 then begin
469 SetLength(FSamplePointers, FSampleCount + 1);
470 FSamplePointers[FSampleCount] := Ptr;
471 Inc(FSampleCount);
472 end;
473 end;
474 end;
475 $07: begin // PATN
476 for K := 0 to ElemCount - 1 do begin
477 Ptr := ReadI32;
478 if Ptr <> 0 then begin
479 SetLength(FPatternPointers, FPatternCountGlobal + 1);
480 FPatternPointers[FPatternCountGlobal] := Ptr;
481 Inc(FPatternCountGlobal);
482 end;
483 end;
484 end;
485 else
486 // Skip unknown element's pointer list
487 Skip(ElemCount * 4);
488 end;
489 until False;
490
491 if Sng2Pointer < 0 then
492 raise EFurException.Create('INF2 block did not list any subsong (SNG2).');
493
494 ParseSng2(Sng2Pointer);
495 end;
496
497 procedure TFurReader.ParseSng2(Offset: Integer);
498 var
499 Magic: TBytes;
500 I, X, Y: Integer;
501 OrderVal: Byte;
502 First16Speed: Word;
503 begin
504 Seek(Offset);
505 Magic := ReadBytes(4); // "SNG2"
506 if (System.Length(Magic) < 4) or (Magic[0] <> Ord('S')) or (Magic[1] <> Ord('N'))
507 or (Magic[2] <> Ord('G')) or (Magic[3] <> Ord('2')) then
508 raise EFurException.Create('Expected SNG2 block.');
509 ReadI32; // size
510
511 FTicksPerSecond := ReadF32;
512 ReadU8; // initial arp time (ignored)
513 FTimeBase := ReadU8; // effect speed divider (a.k.a. time base)
514 FPatternLen := ReadU16;
515 FOrdersLen := ReadU16;
516 FHighlightA := ReadU8;
517 ReadU8; // highlight B
518 FVirtualTempoNum := ReadU16;
519 FVirtualTempoDen := ReadU16;
520 FSpeedPatternLen := ReadU8;
521 for I := 0 to 15 do begin
522 First16Speed := ReadU16;
523 if I = 0 then FSpeed1 := Byte(First16Speed);
524 if I < 16 then FSpeedPattern[I] := Byte(First16Speed);
525 end;
526
527 ReadCString; // subsong name
528 ReadCString; // subsong comment
529
530 // Order table — (channels × orders) bytes, chan-major
531 SetLength(FOrderTable, FTotalChanCount);
532 for X := 0 to FTotalChanCount - 1 do begin
533 SetLength(FOrderTable[X], FOrdersLen);
534 for Y := 0 to FOrdersLen - 1 do begin
535 OrderVal := ReadU8;
536 FOrderTable[X, Y] := OrderVal;
537 end;
538 end;
539
540 Skip(FTotalChanCount); // effect columns
541 Skip(FTotalChanCount); // hide status
542 Skip(FTotalChanCount); // collapse status
543 for X := 0 to FTotalChanCount - 1 do ReadCString; // chan name
544 for X := 0 to FTotalChanCount - 1 do ReadCString; // chan short name
545 Skip(FTotalChanCount * 4); // chan colors (ABGR)
546 end;
547
548 procedure TFurReader.ParseSongInfo;
549 var
550 InfoMagic: TBytes;
551 Chip: Byte;
552 X, Y: Integer;
553 OrderVal: Byte;
554 ChipCount: Integer;
555 AdditionalSubsongs: Integer;
556 SubsongPtrs: Integer;
557 begin
558 InfoMagic := ReadBytes(4); // "INFO"
559 ReadI32; // block size
560
561 FTimeBase := ReadU8;
562 FSpeed1 := ReadU8;
563 ReadU8; // speed2
564 ReadU8; // initial arp time
565 FTicksPerSecond := ReadF32;
566 FPatternLen := ReadU16;
567 FOrdersLen := ReadU16;
568 FHighlightA := ReadU8;
569 ReadU8; // highlightB
570
571 FInstrumentCount := ReadU16;
572 FWavetableCount := ReadU16;
573 FSampleCount := ReadU16;
574 FPatternCountGlobal := ReadI32;
575
576 // Chip types list (32 bytes)
577 ChipCount := 0;
578 FTotalChanCount := 0;
579 for X := 0 to 31 do begin
580 Chip := ReadU8;
581 if Chip = 0 then Continue;
582 if Chip <> CHIP_GAME_BOY then
583 raise EFurException.CreateFmt(
584 'This .fur uses chip $%.2x. Only pure Game Boy modules are supported.',
585 [Chip]);
586 Inc(ChipCount);
587 Inc(FTotalChanCount, 4);
588 end;
589 if ChipCount = 0 then
590 raise EFurException.Create('Module has no sound chips.');
591 // Skip rest of the chip list (we already read all 32)
592
593 Skip(32); // chip vol list
594 Skip(32); // chip pan list
595 if FVersion >= 118 then
596 Skip(128) // chip flag pointers
597 else
598 Skip(128); // legacy flags (one byte each)
599
600 FSongName := ReadCString;
601 FAuthor := ReadCString;
602
603 ReadF32; // A4 tuning
604 Skip(20); // Limit..ResetNoteBaseOnArpEffectStop compat flags
605
606 // Instrument/Wavetable/Sample/Pattern pointer tables
607 SetLength(FInstrumentPointers, FInstrumentCount);
608 for X := 0 to FInstrumentCount - 1 do
609 FInstrumentPointers[X] := ReadI32;
610
611 SetLength(FWavetablePointers, FWavetableCount);
612 for X := 0 to FWavetableCount - 1 do
613 FWavetablePointers[X] := ReadI32;
614
615 SetLength(FSamplePointers, FSampleCount);
616 for X := 0 to FSampleCount - 1 do
617 FSamplePointers[X] := ReadI32;
618
619 SetLength(FPatternPointers, FPatternCountGlobal);
620 for X := 0 to FPatternCountGlobal - 1 do
621 FPatternPointers[X] := ReadI32;
622
623 // Order table: channels outer, rows inner (like fur stores it)
624 SetLength(FOrderTable, FTotalChanCount);
625 for X := 0 to FTotalChanCount - 1 do begin
626 SetLength(FOrderTable[X], FOrdersLen);
627 for Y := 0 to FOrdersLen - 1 do begin
628 OrderVal := ReadU8;
629 FOrderTable[X, Y] := OrderVal;
630 end;
631 end;
632
633 // Per-channel metadata
634 Skip(FTotalChanCount); // effect column counts
635 Skip(FTotalChanCount); // channel hide status
636 Skip(FTotalChanCount); // channel collapse status
637 for X := 0 to FTotalChanCount - 1 do ReadCString; // chan name
638 for X := 0 to FTotalChanCount - 1 do ReadCString; // chan short name
639
640 FSongComment := ReadCString;
641 ReadF32; // master volume
642
643 // Extended compatibility flags (>= v70): 28 bytes
644 Skip(28);
645
646 FVirtualTempoNum := ReadU16;
647 FVirtualTempoDen := ReadU16;
648
649 // Subsong name/comment (for song 0) — we discard
650 ReadCString;
651 ReadCString;
652 AdditionalSubsongs := ReadU8;
653 Skip(3); // reserved
654
655 // Subsong pointers — ignored
656 for X := 0 to AdditionalSubsongs - 1 do
657 SubsongPtrs := ReadI32;
658
659 // SysName + localization strings
660 ReadCString; ReadCString; ReadCString; ReadCString; ReadCString; ReadCString;
661
662 // Extra chip output settings (only 1 chip in our GB-only case): 12 bytes
663 Skip(12);
664
665 // Patchbay (>=135) — we've already version-gated the file to >=157
666 Skip(ReadI32 * 4);
667 ReadU8; // AutoPatchBay
668
669 // More compat flags (>=138): 8 bytes
670 Skip(8);
671
672 // Speed pattern (>=139): 1 byte len + 16 bytes pattern
673 FSpeedPatternLen := ReadU8;
674 if (FSpeedPatternLen < 0) or (FSpeedPatternLen > 16) then
675 raise EFurException.CreateFmt('Speed pattern length out of range: %d',
676 [FSpeedPatternLen]);
677 for X := 0 to 15 do
678 FSpeedPattern[X] := ReadU8;
679
680 // Groove list
681 ChipCount := ReadU8; // groove count (reusing var)
682 Skip(ChipCount * 17); // len byte + 16 bytes
683
684 // Pointers to asset directories (>=156)
685 Skip(12);
686 end;
687
688 function FeatureCode(const S: String): Integer;
689 begin
690 if S = 'NA' then Result := FEAT_NAME
691 else if S = 'MA' then Result := FEAT_MACRO
692 else if S = 'GB' then Result := FEAT_GB
693 else if S = 'WS' then Result := FEAT_WS
694 else if S = 'EN' then Result := FEAT_END
695 else Result := FEAT_IGNORE;
696 end;
697
698 procedure TFurReader.ParseInstruments;
699 var
700 I, J, K: Integer;
701 FormatMagic: TBytes;
702 BlockSize, InstFormatVer: Integer;
703 InstrType: Word;
704 FCode: String;
705 FeatTag: TBytes;
706 BlockLen: Integer;
707 Inst: TFurInstrument;
708 StopLoop: Boolean;
709 Name: String;
710 NameLen: Integer;
711 // GB
712 EnvParams: Byte;
713 // Macros
714 MacroHeaderLen: Integer;
715 MacroCode: Byte;
716 MacroLen, MacroLoop, MacroRelease, MacroMode: Byte;
717 MacroOTWSByte: Byte;
718 WordSize: Integer;
719 MacroDelay, MacroSpeed: Byte;
720 WordBytes: Integer;
721 TotalBytes: Integer;
722 M: TFurMacro;
723 // WS
724 WSFirstWave: Integer;
725 begin
726 for I := 0 to FInstrumentCount - 1 do begin
727 if FVersion < 127 then
728 Continue; // Legacy instrument format not supported
729
730 Seek(FInstrumentPointers[I]);
731 FormatMagic := ReadBytes(4); // "INS2"
732 BlockSize := ReadI32;
733 InstFormatVer := ReadU16;
734 InstrType := ReadU16;
735
736 Inst := TFurInstrument.Create;
737 Inst.InstFormatVersion := InstFormatVer;
738 Inst.ID := FInstruments.Count;
739 // Default GB envelope (matches fur2uge defaults so empty-GB instruments work)
740 Inst.GB.Present := True;
741 Inst.GB.EnvLen := 2;
742 Inst.GB.EnvDir := 0;
743 Inst.GB.EnvVol := 15;
744 Inst.GB.SndLen := 2;
745 FInstruments.Add(Inst);
746
747 StopLoop := False;
748 while not StopLoop do begin
749 FeatTag := ReadBytes(2);
750 SetLength(FCode, 2);
751 Move(FeatTag[0], FCode[1], 2);
752 BlockLen := ReadU16;
753
754 case FeatureCode(FCode) of
755 FEAT_END:
756 StopLoop := True;
757
758 FEAT_NAME: begin
759 Name := ReadCString;
760 Inst.Name := Name;
761 NameLen := System.Length(Name) + 1;
762 if BlockLen > NameLen then
763 Skip(BlockLen - NameLen);
764 end;
765
766 FEAT_MACRO: begin
767 MacroHeaderLen := ReadU16;
768 Dec(BlockLen, 2);
769 while BlockLen > 0 do begin
770 if BlockLen = 1 then begin
771 ReadU8;
772 Dec(BlockLen);
773 Break;
774 end;
775 MacroCode := ReadU8;
776 MacroLen := ReadU8;
777 MacroLoop := ReadU8;
778 MacroRelease := ReadU8;
779 MacroMode := ReadU8;
780 MacroOTWSByte := ReadU8;
781 WordSize := ((MacroOTWSByte shr 6) and $03); // bits 6,7
782 MacroDelay := ReadU8;
783 MacroSpeed := ReadU8;
784 Dec(BlockLen, 8);
785
786 case WordSize of
787 0: WordBytes := 1; // U8
788 1: WordBytes := 1; // S8
789 2: WordBytes := 2; // S16
790 3: WordBytes := 4; // S32
791 end;
792 TotalBytes := MacroLen * WordBytes;
793
794 M.Code := MacroCode;
795 M.LoopPoint := MacroLoop;
796 SetLength(M.Data, MacroLen);
797 for J := 0 to MacroLen - 1 do begin
798 case WordSize of
799 0: M.Data[J] := ReadU8;
800 1: M.Data[J] := ShortInt(ReadU8);
801 2: M.Data[J] := SmallInt(ReadU16);
802 3: M.Data[J] := ReadI32;
803 end;
804 end;
805 Dec(BlockLen, TotalBytes);
806
807 if MacroCode <> $FF then
808 Inst.AddMacro(M);
809 SetLength(M.Data, 0);
810 end;
811 end;
812
813 FEAT_GB: begin
814 EnvParams := ReadU8;
815 Inst.GB.EnvLen := (EnvParams shr 5) and $07; // bits 5,6,7
816 if (EnvParams and $10) <> 0 then
817 Inst.GB.EnvDir := 1
818 else
819 Inst.GB.EnvDir := 0;
820 Inst.GB.EnvVol := EnvParams and $0F;
821 Inst.GB.SndLen := ReadU8;
822 Inst.GB.Flags := ReadU8;
823 K := ReadU8; // hw seq len
824 Dec(BlockLen, 4);
825
826 SetLength(Inst.GB.HWSeq, K);
827 for J := 0 to K - 1 do begin
828 Inst.GB.HWSeq[J].CmdType := ReadU8;
829 MacroCode := ReadU8; // reuse var as data1
830 MacroLen := ReadU8; // data2
831
832 if Inst.GB.HWSeq[J].CmdType = 1 then begin
833 // SET_SWEEP
834 Inst.GB.HWSeq[J].SweepSpeed := (MacroCode shr 4) and $07;
835 if (MacroCode and $08) <> 0 then
836 Inst.GB.HWSeq[J].SweepDir := 1
837 else
838 Inst.GB.HWSeq[J].SweepDir := 0;
839 Inst.GB.HWSeq[J].ShiftVal := MacroCode and $07;
840 end;
841 Dec(BlockLen, 3);
842 end;
843 if BlockLen > 0 then Skip(BlockLen);
844 end;
845
846 FEAT_WS: begin
847 Inst.WS.Present := True;
848 WSFirstWave := ReadI32;
849 ReadI32; // second wave
850 ReadU8; // rate divider
851 ReadU8; // effect
852 Inst.WS.Enabled := ReadU8 > 0;
853 ReadU8; // global
854 ReadU8; // speed
855 Skip(4); // param1..4
856 Inst.WS.FirstWave := WSFirstWave;
857 Dec(BlockLen, 17);
858 if BlockLen > 0 then Skip(BlockLen);
859 end;
860
861 else
862 // unhandled feature — skip its payload
863 Skip(BlockLen);
864 end;
865 end;
866 end;
867 end;
868
869 procedure TFurReader.ParseWavetables;
870 var
871 I, J: Integer;
872 Width: Integer;
873 Block: TBytes;
874 begin
875 SetLength(FWaveforms, FWavetableCount);
876 for I := 0 to FWavetableCount - 1 do begin
877 Seek(FWavetablePointers[I]);
878 ReadBytes(4); // "WAVE"
879 ReadI32; // block size
880 ReadCString; // name
881 Width := ReadI32;
882 ReadI32; // reserved
883 ReadI32; // height
884
885 SetLength(Block, Width);
886 for J := 0 to Width - 1 do
887 Block[J] := Byte(ReadI32 and $FF);
888 FWaveforms[I] := Block;
889 end;
890 end;
891
892 procedure TFurReader.ParsePatterns;
893 var
894 I, J: Integer;
895 SubSong, ChannelID, Ver: Integer;
896 PatIndex: Word;
897 Row: Integer;
898 Pat: TFurPattern;
899 Cell: TFurCell;
900 FirstByte, SecondByte, ThirdByte: Byte;
901 SkipCounter: Integer;
902 DataWritten: Boolean;
903 NotePresent, InstPresent, VolPresent: Boolean;
904 FxPresent, FxValPresent: array[0..7] of Boolean;
905 Bit5Set, Bit6Set: Boolean;
906 PatternsParsed: Integer;
907
908 procedure ClearCell(out C: TFurCell);
909 var K: Integer;
910 begin
911 C.Row := 0;
912 C.Note := -9999;
913 C.Instrument := -9999;
914 C.Volume := -9999;
915 for K := 0 to 7 do begin
916 C.FxPresent[K] := False;
917 C.FxValPresent[K] := False;
918 C.Fx[K] := 0;
919 C.FxVal[K] := 0;
920 end;
921 end;
922
923 begin
924 PatternsParsed := 0;
925 for I := 0 to FPatternCountGlobal - 1 do begin
926 if FVersion < 157 then Continue;
927
928 Seek(FPatternPointers[I]);
929 ReadBytes(4); // "PATN" block id
930 ReadI32; // block size
931 SubSong := ReadU8;
932 ChannelID := ReadU8;
933 PatIndex := ReadU16;
934 ReadCString; // pattern name
935
936 if SubSong <> 0 then Continue; // we only handle song 0
937 if ChannelID > 3 then Continue;
938
939 Pat := TFurPattern.Create;
940 Pat.Length := FPatternLen;
941 FPatterns[ChannelID].Add(PatIndex, Pat);
942 Inc(PatternsParsed);
943
944 Row := 0;
945 while Row < FPatternLen do begin
946 FirstByte := ReadU8;
947 if FirstByte = $FF then Break;
948
949 if (FirstByte and $80) <> 0 then begin
950 SkipCounter := FirstByte and $3F;
951 Inc(Row, SkipCounter + 2);
952 Continue;
953 end;
954
955 ClearCell(Cell);
956 Cell.Row := Row;
957 DataWritten := False;
958
959 NotePresent := (FirstByte and $01) <> 0;
960 InstPresent := (FirstByte and $02) <> 0;
961 VolPresent := (FirstByte and $04) <> 0;
962 FxPresent[0] := (FirstByte and $08) <> 0;
963 FxValPresent[0] := (FirstByte and $10) <> 0;
964 Bit5Set := (FirstByte and $20) <> 0;
965 Bit6Set := (FirstByte and $40) <> 0;
966 for J := 1 to 7 do begin
967 FxPresent[J] := False;
968 FxValPresent[J] := False;
969 end;
970
971 if Bit5Set then begin
972 SecondByte := ReadU8;
973 FxPresent[0] := (SecondByte and $01) <> 0;
974 FxValPresent[0] := (SecondByte and $02) <> 0;
975 FxPresent[1] := (SecondByte and $04) <> 0;
976 FxValPresent[1] := (SecondByte and $08) <> 0;
977 FxPresent[2] := (SecondByte and $10) <> 0;
978 FxValPresent[2] := (SecondByte and $20) <> 0;
979 FxPresent[3] := (SecondByte and $40) <> 0;
980 FxValPresent[3] := (SecondByte and $80) <> 0;
981 if (SecondByte and $40) <> 0 then begin
982 ThirdByte := ReadU8;
983 FxPresent[4] := (ThirdByte and $01) <> 0;
984 FxValPresent[4] := (ThirdByte and $02) <> 0;
985 FxPresent[5] := (ThirdByte and $04) <> 0;
986 FxValPresent[5] := (ThirdByte and $08) <> 0;
987 FxPresent[6] := (ThirdByte and $10) <> 0;
988 FxValPresent[6] := (ThirdByte and $20) <> 0;
989 FxPresent[7] := (ThirdByte and $40) <> 0;
990 FxValPresent[7] := (ThirdByte and $80) <> 0;
991 end;
992 end;
993
994 if NotePresent then begin Cell.Note := ReadU8; DataWritten := True; end;
995 if InstPresent then begin Cell.Instrument := ReadU8; DataWritten := True; end;
996 if VolPresent then begin Cell.Volume := ReadU8; DataWritten := True; end;
997
998 for J := 0 to 7 do begin
999 Cell.FxPresent[J] := FxPresent[J];
1000 Cell.FxValPresent[J] := FxValPresent[J];
1001 if FxPresent[J] then begin Cell.Fx[J] := ReadU8; DataWritten := True; end;
1002 if FxValPresent[J] then begin Cell.FxVal[J] := ReadU8; DataWritten := True; end;
1003 end;
1004
1005 if DataWritten then
1006 Pat.Add(Cell);
1007
1008 Inc(Row);
1009 end;
1010 end;
1011 end;
1012
1013 procedure TFurReader.Parse;
1014 var
1015 BlockId: TBytes;
1016 Tag: String;
1017 begin
1018 ParseHeader;
1019
1020 // Peek at the first block ID to decide between INFO (old) and INF2 (new).
1021 BlockId := ReadBytes(4);
1022 SetLength(Tag, 4);
1023 Move(BlockId[0], Tag[1], 4);
1024 if Tag = 'INF2' then
1025 ParseInfo2
1026 else if Tag = 'INFO' then begin
1027 // Rewind so ParseSongInfo can read the block ID again.
1028 Seek(FPos - 4);
1029 ParseSongInfo;
1030 end else
1031 raise EFurException.CreateFmt(
1032 'Unexpected block after header: %s (expected INFO or INF2).', [Tag]);
1033
1034 ParseInstruments;
1035 ParseWavetables;
1036 ParsePatterns;
1037 end;
1038
1039 function TFurReader.SpeedPatternValue(I: Integer): Byte;
1040 begin
1041 if (I < 0) or (I > 15) then
1042 Result := 0
1043 else
1044 Result := FSpeedPattern[I];
1045 end;
1046
1047 function TFurReader.Waveform(I: Integer): TBytes;
1048 begin
1049 if (I < 0) or (I >= System.Length(FWaveforms)) then
1050 Result := nil
1051 else
1052 Result := FWaveforms[I];
1053 end;
1054
1055 function TFurReader.OrderAt(Chan, Row: Integer): Integer;
1056 begin
1057 Result := FOrderTable[Chan, Row];
1058 end;
1059
1060 function TFurReader.GetPattern(Chan, Index: Integer): TFurPattern;
1061 var
1062 Idx: Integer;
1063 begin
1064 Result := nil;
1065 Idx := FPatterns[Chan].IndexOf(Index);
1066 if Idx >= 0 then
1067 Result := FPatterns[Chan].Data[Idx];
1068 end;
1069
1070 { ==== Conversion helpers ==== }
1071
1072 function FurNoteToUgeNote(FurNote: Integer): Integer;
1073 begin
1074 if FurNote = 180 then
1075 Result := 180 // sentinel meaning "note cut"
1076 else
1077 Result := FurNote - 84;
1078 end;
1079
1080 // Compute Furnace→hUGE (TimerDivider, TicksPerRow) for a non-GBStudio target
1081 procedure ConvertFurTempo(TimeBase: Integer; AvgSpeed: Double;
1082 VTNum, VTDen: Integer; TickRateHz: Double; HighlightA: Integer;
1083 out TicksPerRow, TimerDivider: Integer);
1084 var
1085 HL, TB, VN, VD, SourceBpm, Bpm, BestErr, Err: Double;
1086 Div_: Integer;
1087 BestDiv: Integer;
1088 begin
1089 if HighlightA > 0 then HL := HighlightA else HL := 4.0;
1090 if (TimeBase + 1) > 1 then TB := TimeBase + 1 else TB := 1.0;
1091 VN := Max(VTNum, 1);
1092 VD := Max(VTDen, 1);
1093
1094 SourceBpm := (60.0 * TickRateHz) / (AvgSpeed * HL * TB) * (VN / VD);
1095
1096 TicksPerRow := Round(AvgSpeed);
1097 if TicksPerRow < 1 then TicksPerRow := 1;
1098
1099 BestErr := 1e30;
1100 BestDiv := 0;
1101 for Div_ := 1 to 254 do begin
1102 Bpm := (4096.0 * 15.0) / ((256 - Div_) * TicksPerRow);
1103 Err := Abs(Bpm - SourceBpm);
1104 if Err < BestErr then begin
1105 BestErr := Err;
1106 BestDiv := Div_;
1107 end;
1108 end;
1109 TimerDivider := BestDiv;
1110 end;
1111
1112 function ZLibDecompress(Stream: TStream): TBytes;
1113 var
1114 Ds: TDecompressionStream;
1115 Buffer: TBytes;
1116 Read, Total, Cap: Integer;
1117 begin
1118 Stream.Position := 0;
1119 Ds := TDecompressionStream.Create(Stream);
1120 try
1121 Total := 0;
1122 Cap := 65536;
1123 SetLength(Buffer, Cap);
1124 repeat
1125 if Total + 65536 > Cap then begin
1126 Cap := Cap * 2;
1127 SetLength(Buffer, Cap);
1128 end;
1129 Read := Ds.Read(Buffer[Total], Cap - Total);
1130 Inc(Total, Read);
1131 until Read = 0;
1132 SetLength(Buffer, Total);
1133 Result := Buffer;
1134 finally
1135 Ds.Free;
1136 end;
1137 end;
1138
1139 function LoadAllBytes(Stream: TStream): TBytes;
1140 var
1141 N: Int64;
1142 begin
1143 Stream.Position := 0;
1144 N := Stream.Size;
1145 SetLength(Result, N);
1146 if N > 0 then
1147 Stream.ReadBuffer(Result[0], N);
1148 end;
1149
1150 { ==== Subpattern population from Furnace macros ==== }
1151
1152 procedure ApplyMacrosToSubpattern(var Sub: TPattern; const Inst: TFurInstrument;
1153 PanMacroOnChannel: Integer);
1154 var
1155 I, J, BitA, BitB, LoopOffset: Integer;
1156 HighestRow, HighestLoop: Integer;
1157 HadJumpable: Boolean;
1158 Data: array of Integer;
1159 LoopPt: Integer;
1160 PanVal, PanFinal: Integer;
1161 RightOn, LeftOn: Boolean;
1162 ArpVal, PitchVal: ShortInt;
1163 HasSubpatternData: Boolean;
1164 begin
1165 BlankPattern(@Sub);
1166 HadJumpable := False;
1167 HighestRow := 0;
1168 HighestLoop := 0;
1169 HasSubpatternData := False;
1170
1171 for I := System.Length(Inst.Macros) - 1 downto 0 do begin
1172 Data := Inst.Macros[I].Data;
1173 LoopPt := Inst.Macros[I].LoopPoint;
1174 if System.Length(Data) > 1 then HasSubpatternData := True;
1175
1176 case Inst.Macros[I].Code of
1177 MC_PAN_L: begin
1178 if System.Length(Data) > 1 then begin
1179 BitA := PanMacroOnChannel - 1;
1180 BitB := PanMacroOnChannel + 3;
1181 for J := 0 to System.Length(Data) - 1 do begin
1182 if J > High(Sub) then Break;
1183 PanVal := Data[J];
1184 RightOn := (PanVal and 1) <> 0;
1185 LeftOn := (PanVal and 2) <> 0;
1186 PanFinal := $FF;
1187 if RightOn then PanFinal := PanFinal or (1 shl BitA)
1188 else PanFinal := PanFinal and (not (1 shl BitA));
1189 if LeftOn then PanFinal := PanFinal or (1 shl BitB)
1190 else PanFinal := PanFinal and (not (1 shl BitB));
1191 Sub[J].EffectCode := HFX_SET_PANNING;
1192 Sub[J].EffectParams.Value := Byte(PanFinal);
1193 end;
1194 end;
1195 end;
1196 MC_ARP: begin
1197 if System.Length(Data) > 1 then begin
1198 for J := 0 to System.Length(Data) - 1 do begin
1199 if J > High(Sub) then Break;
1200 ArpVal := ShortInt(Data[J] and $FF);
1201 Sub[J].Note := $24 + ArpVal;
1202 end;
1203 end;
1204 end;
1205 MC_PITCH: begin
1206 if System.Length(Data) > 1 then begin
1207 for J := 0 to System.Length(Data) - 1 do begin
1208 if J > High(Sub) then Break;
1209 PitchVal := ShortInt(Data[J] and $FF);
1210 if PitchVal >= 0 then begin
1211 Sub[J].EffectCode := HFX_PORTA_UP;
1212 Sub[J].EffectParams.Value := Byte(PitchVal div 8);
1213 end else begin
1214 Sub[J].EffectCode := HFX_PORTA_DOWN;
1215 Sub[J].EffectParams.Value := Byte((-PitchVal) div 8);
1216 end;
1217 end;
1218 end;
1219 end;
1220 MC_DUTY: begin
1221 if System.Length(Data) > 1 then begin
1222 for J := 0 to System.Length(Data) - 1 do begin
1223 if J > High(Sub) then Break;
1224 Sub[J].EffectCode := HFX_SET_DUTY;
1225 Sub[J].EffectParams.Value := Byte(Data[J] * $40);
1226 end;
1227 end;
1228 end;
1229 end;
1230
1231 if (System.Length(Data) > 1) and (LoopPt < $FF) then begin
1232 if HighestLoop <= LoopPt then begin
1233 HighestRow := System.Length(Data) - 1;
1234 HighestLoop := LoopPt;
1235 HadJumpable := True;
1236 end;
1237 end;
1238 end;
1239
1240 if HadJumpable then begin
1241 LoopOffset := 0;
1242 if HighestLoop = HighestRow then LoopOffset := 1;
1243 if (HighestRow >= Low(Sub)) and (HighestRow <= High(Sub)) then
1244 Sub[HighestRow].Volume := HighestLoop + LoopOffset;
1245 end else if (System.Length(Inst.Macros) > 0) then begin
1246 if System.Length(Inst.Macros[0].Data) > 1 then begin
1247 J := System.Length(Inst.Macros[0].Data);
1248 if (J >= Low(Sub)) and (J <= High(Sub)) then
1249 Sub[J].Volume := J;
1250 end;
1251 end;
1252 end;
1253
1254 { ==== Main import ==== }
1255
1256 function LoadSongFromFurStream(Stream: TStream): TSong;
1257 var
1258 Raw, Decompressed: TBytes;
1259 Reader: TFurReader;
1260 I, J, K, ChanID, OrderRow, OrdersLen, FurPatId, UgePatId: Integer;
1261 NextUgeId: Integer;
1262 Key: Int64;
1263 FurPointerMap: specialize TFPGMap<Int64, Integer>;
1264 Pat: PPattern;
1265 FurPat: TFurPattern;
1266 SubCell: TFurCell;
1267 PrevRow, RowsSincePrev, RowsToEnd: Integer;
1268 PatLen: Integer;
1269 FurFxCmd, FurFxVal, UgeFxVal: Byte;
1270 FurFxCmdPresent, FurFxValPresent: Boolean;
1271 UgeFxCmd: Integer;
1272 PulseInsts, WaveInsts, NoiseInsts: array of Integer; // fur IDs in order of first use
1273 TargetInst: Integer;
1274 DuplicateFound: Boolean;
1275 InstVal: Integer;
1276 NoteCode: Integer;
1277 OutVol: Byte;
1278 GbVol, GbLen, GbDir: Integer;
1279 TicksPerRow, TimerDivider: Integer;
1280 SpeedAvg: Double;
1281 RowIdx: Integer;
1282 WavData: TBytes;
1283 RemapInst: Integer;
1284 FurInst: TFurInstrument;
1285 HInst: ^TInstrument;
1286 HInstBank: TInstrumentType;
1287 PanLeft, PanRight: array[0..3] of Boolean;
1288 FinalPan: Integer;
1289 UseEffect: Boolean;
1290
1291 function CopyContinueEffect(Cmd: Integer): Boolean;
1292 begin
1293 Result := (Cmd <> HFX_NOTE_DELAY) and (Cmd <> HFX_NOTE_CUT)
1294 and (Cmd <> HFX_SET_SPEED) and (Cmd <> HFX_SET_PANNING)
1295 and (Cmd >= 0);
1296 end;
1297
1298 procedure SetEffectOnPat(APat: PPattern; ARow: Integer;
1299 Cmd: Integer; Param: Byte);
1300 begin
1301 if (ARow < Low(TPattern)) or (ARow > High(TPattern)) then Exit;
1302 APat^[ARow].EffectCode := Cmd;
1303 APat^[ARow].EffectParams.Value := Param;
1304 end;
1305
1306 begin
1307 InitializeSong(Result);
1308
1309 Raw := LoadAllBytes(Stream);
1310 if System.Length(Raw) < 2 then
1311 raise EFurException.Create('File too small to be a .fur module.');
1312
1313 if (Raw[0] = $78) and (Raw[1] = $9C) then begin
1314 Stream.Position := 0;
1315 Decompressed := ZLibDecompress(Stream);
1316 end else
1317 Decompressed := Raw;
1318
1319 Reader := TFurReader.Create(Decompressed);
1320 FurPointerMap := specialize TFPGMap<Int64, Integer>.Create;
1321 try
1322 Reader.Parse;
1323
1324 if Reader.PatternLen <> 64 then
1325 raise EFurException.CreateFmt(
1326 'Pattern length must be 64 (got %d). Adjust in Furnace and re-export.',
1327 [Reader.PatternLen]);
1328 if Reader.TotalChanCount <> 4 then
1329 raise EFurException.CreateFmt(
1330 'Expected 4 Game Boy channels, got %d.', [Reader.TotalChanCount]);
1331
1332 Result.Name := Reader.SongName;
1333 Result.Artist := Reader.Author;
1334 Result.Comment := Reader.SongComment;
1335
1336 // Waveforms
1337 for I := 0 to Min(Reader.WavetableCount, System.Length(Result.Waves)) - 1 do begin
1338 WavData := Reader.Waveform(I);
1339 if WavData = nil then Continue;
1340 for J := 0 to Min(System.Length(WavData), System.Length(Result.Waves[I])) - 1 do
1341 Result.Waves[I][J] := WavData[J] and $0F;
1342 end;
1343
1344 // Tempo
1345 SpeedAvg := Reader.Speed1;
1346 if (Reader.SpeedPatternLen > 1) then begin
1347 K := 0;
1348 SpeedAvg := 0;
1349 for I := 0 to Reader.SpeedPatternLen - 1 do begin
1350 SpeedAvg := SpeedAvg + Reader.SpeedPatternValue(I);
1351 Inc(K);
1352 end;
1353 if K > 0 then SpeedAvg := SpeedAvg / K;
1354 end;
1355 ConvertFurTempo(Reader.TimeBase, SpeedAvg,
1356 Reader.VirtualTempoNum, Reader.VirtualTempoDen,
1357 Reader.TicksPerSecond, Reader.HighlightA,
1358 TicksPerRow, TimerDivider);
1359 Result.TicksPerRow := TicksPerRow;
1360 Result.TimerDivider := TimerDivider;
1361 Result.TimerEnabled := True;
1362
1363 // Build unique (channel, fur-pattern) → uge-pattern-id mapping
1364 OrdersLen := Reader.OrdersLen;
1365 NextUgeId := 0;
1366 for I := 0 to 3 do begin
1367 SetLength(Result.OrderMatrix[I], OrdersLen + 1);
1368 end;
1369 for ChanID := 0 to 3 do begin
1370 for OrderRow := 0 to OrdersLen - 1 do begin
1371 FurPatId := Reader.OrderAt(ChanID, OrderRow);
1372 Key := (Int64(ChanID) shl 32) or FurPatId;
1373 if not FurPointerMap.TryGetData(Key, UgePatId) then begin
1374 UgePatId := NextUgeId;
1375 FurPointerMap.Add(Key, UgePatId);
1376 Inc(NextUgeId);
1377 // Seed a blank pattern in the map so channels w/ no data still exist
1378 Result.Patterns.GetOrCreateNew(UgePatId);
1379 end;
1380 Result.OrderMatrix[ChanID, OrderRow] := UgePatId;
1381 end;
1382 // Off-by-one slot at the end: point at the last valid pattern
1383 if OrdersLen > 0 then
1384 Result.OrderMatrix[ChanID, OrdersLen] := Result.OrderMatrix[ChanID, OrdersLen - 1];
1385 end;
1386
1387 // Initial pan state — every channel unpanned (both sides on)
1388 for I := 0 to 3 do begin
1389 PanLeft[I] := True;
1390 PanRight[I] := True;
1391 end;
1392
1393 // Fill pattern rows per channel / order, tracking continuing effects
1394 SetLength(PulseInsts, 0);
1395 SetLength(WaveInsts, 0);
1396 SetLength(NoiseInsts, 0);
1397
1398 for ChanID := 0 to 3 do begin
1399 for OrderRow := 0 to OrdersLen - 1 do begin
1400 UgePatId := Result.OrderMatrix[ChanID, OrderRow];
1401 Pat := Result.Patterns.GetOrCreateNew(UgePatId);
1402
1403 FurPatId := Reader.OrderAt(ChanID, OrderRow);
1404 FurPat := Reader.GetPattern(ChanID, FurPatId);
1405 if FurPat = nil then Continue;
1406
1407 PatLen := FurPat.Length;
1408 PrevRow := 0;
1409 UgeFxCmd := -1;
1410 UgeFxVal := 0;
1411
1412 for I := 0 to System.Length(FurPat.Rows) - 1 do begin
1413 SubCell := FurPat.Rows[I];
1414 RowIdx := SubCell.Row;
1415
1416 // Fill "iterative" continuing effects on any skipped rows since prev
1417 if PrevRow > 0 then begin
1418 RowsSincePrev := RowIdx - PrevRow;
1419 for K := RowsSincePrev - 1 downto 1 do begin
1420 if (UgeFxVal = 0) or (UgeFxCmd < 0) then Break;
1421 if not CopyContinueEffect(UgeFxCmd) then Break;
1422 SetEffectOnPat(Pat, RowIdx - K, UgeFxCmd, UgeFxVal);
1423 end;
1424 end;
1425 PrevRow := RowIdx;
1426
1427 // If this is the last-data row, extrapolate effects to end of pattern
1428 if I = System.Length(FurPat.Rows) - 1 then begin
1429 RowsToEnd := PatLen - RowIdx;
1430 for K := 1 to RowsToEnd - 1 do begin
1431 if (UgeFxVal = 0) or (UgeFxCmd < 0) then Break;
1432 if not CopyContinueEffect(UgeFxCmd) then Break;
1433 SetEffectOnPat(Pat, RowIdx + K, UgeFxCmd, UgeFxVal);
1434 end;
1435 end;
1436
1437 // Note
1438 if SubCell.Note >= 0 then begin
1439 NoteCode := FurNoteToUgeNote(SubCell.Note);
1440 if NoteCode = 180 then begin
1441 // Note cut effect
1442 Pat^[RowIdx].EffectCode := HFX_NOTE_CUT;
1443 Pat^[RowIdx].EffectParams.Value := 0;
1444 end else begin
1445 if ChanID = 3 then NoteCode := NoteCode + 19;
1446 if (NoteCode >= 0) and (NoteCode < NO_NOTE) then
1447 Pat^[RowIdx].Note := NoteCode;
1448 end;
1449 end;
1450
1451 // Instrument
1452 InstVal := SubCell.Instrument;
1453 TargetInst := -1;
1454 if (InstVal >= 0) and (InstVal < Reader.Instruments.Count) then begin
1455 FurInst := Reader.Instruments[InstVal];
1456 case ChanID of
1457 0, 1: begin
1458 DuplicateFound := False;
1459 for J := 0 to System.Length(PulseInsts) - 1 do
1460 if PulseInsts[J] = FurInst.ID then begin
1461 DuplicateFound := True;
1462 RemapInst := J;
1463 Break;
1464 end;
1465 if not DuplicateFound then begin
1466 RemapInst := System.Length(PulseInsts);
1467 SetLength(PulseInsts, RemapInst + 1);
1468 PulseInsts[RemapInst] := FurInst.ID;
1469 end;
1470 if RemapInst >= 15 then
1471 raise EFurException.Create(
1472 'Too many unique Pulse instruments (limit: 15).');
1473 Pat^[RowIdx].Instrument := RemapInst + 1;
1474 TargetInst := RemapInst;
1475 end;
1476 2: begin
1477 DuplicateFound := False;
1478 for J := 0 to System.Length(WaveInsts) - 1 do
1479 if WaveInsts[J] = FurInst.ID then begin
1480 DuplicateFound := True;
1481 RemapInst := J;
1482 Break;
1483 end;
1484 if not DuplicateFound then begin
1485 RemapInst := System.Length(WaveInsts);
1486 SetLength(WaveInsts, RemapInst + 1);
1487 WaveInsts[RemapInst] := FurInst.ID;
1488 end;
1489 if RemapInst >= 15 then
1490 raise EFurException.Create(
1491 'Too many unique Wave instruments (limit: 15).');
1492 Pat^[RowIdx].Instrument := RemapInst + 1;
1493 TargetInst := RemapInst;
1494 end;
1495 3: begin
1496 DuplicateFound := False;
1497 for J := 0 to System.Length(NoiseInsts) - 1 do
1498 if NoiseInsts[J] = FurInst.ID then begin
1499 DuplicateFound := True;
1500 RemapInst := J;
1501 Break;
1502 end;
1503 if not DuplicateFound then begin
1504 RemapInst := System.Length(NoiseInsts);
1505 SetLength(NoiseInsts, RemapInst + 1);
1506 NoiseInsts[RemapInst] := FurInst.ID;
1507 end;
1508 if RemapInst >= 15 then
1509 raise EFurException.Create(
1510 'Too many unique Noise instruments (limit: 15).');
1511 Pat^[RowIdx].Instrument := RemapInst + 1;
1512 TargetInst := RemapInst;
1513 end;
1514 end;
1515 end;
1516
1517 // Volume column → SET_VOL effect (combined with envelope length nibble)
1518 if (SubCell.Volume >= 0) and (TargetInst >= 0) then begin
1519 FurInst := Reader.Instruments[InstVal];
1520 GbVol := FurInst.GB.EnvVol;
1521 GbLen := FurInst.GB.EnvLen;
1522 GbDir := FurInst.GB.EnvDir;
1523 if ChanID = 2 then GbLen := 0;
1524 OutVol := Byte(SubCell.Volume) + Byte($F0 and (GbLen shl 4));
1525 Pat^[RowIdx].EffectCode := HFX_SET_VOL;
1526 Pat^[RowIdx].EffectParams.Value := OutVol;
1527 end;
1528
1529 // Effect column (only column 0 is mapped; others pass through untouched)
1530 for J := 0 to 7 do begin
1531 FurFxCmdPresent := SubCell.FxPresent[J];
1532 FurFxValPresent := SubCell.FxValPresent[J];
1533 if not (FurFxCmdPresent or FurFxValPresent) then Continue;
1534
1535 FurFxCmd := SubCell.Fx[J];
1536 FurFxVal := SubCell.FxVal[J];
1537
1538 UgeFxCmd := -1;
1539 UgeFxVal := FurFxVal;
1540 UseEffect := True;
1541
1542 case FurFxCmd of
1543 FX_ARPEGGIO: UgeFxCmd := HFX_ARPEGGIO;
1544 FX_PORTA_UP: UgeFxCmd := HFX_PORTA_UP;
1545 FX_PORTA_DOWN: UgeFxCmd := HFX_PORTA_DOWN;
1546 FX_TONE_PORTA: UgeFxCmd := HFX_TONE_PORTA;
1547 FX_VIBRATO: UgeFxCmd := HFX_VIBRATO;
1548 FX_VOLUME_SLIDE: UgeFxCmd := HFX_VOLUME_SLIDE;
1549 FX_SET_DUTY: UgeFxCmd := HFX_SET_DUTY;
1550 FX_POSITION_JUMP: begin UgeFxCmd := HFX_POSITION_JUMP; Inc(UgeFxVal); end;
1551 FX_PATTERN_BREAK: begin UgeFxCmd := HFX_PATTERN_BREAK; Inc(UgeFxVal); end;
1552 FX_SET_SPEED: UgeFxCmd := HFX_SET_SPEED;
1553 FX_NOTE_CUT: UgeFxCmd := HFX_NOTE_CUT;
1554 FX_NOTE_DELAY: UgeFxCmd := HFX_NOTE_DELAY;
1555 FX_SOFTWARE_PAN: begin
1556 // 0x00 = left, 0x80 = both, 0xFF = right
1557 PanRight[ChanID] := (FurFxVal = $80) or (FurFxVal = $FF);
1558 PanLeft[ChanID] := (FurFxVal = $80) or (FurFxVal = $00);
1559 UgeFxCmd := HFX_SET_PANNING;
1560 FinalPan := 0;
1561 for K := 0 to 3 do begin
1562 if PanLeft[K] then FinalPan := FinalPan or (1 shl K);
1563 if PanRight[K] then FinalPan := FinalPan or (1 shl (K + 4));
1564 end;
1565 UgeFxVal := Byte(FinalPan);
1566 end;
1567 FX_HW_PAN:
1568 UseEffect := False; // Hardware pan conversion not supported
1569 $F1: begin
1570 UgeFxCmd := HFX_SET_SPEED; // noop marker from fur
1571 UseEffect := False;
1572 end;
1573 else
1574 UseEffect := False;
1575 end;
1576
1577 if UseEffect and (UgeFxCmd >= 0) then begin
1578 Pat^[RowIdx].EffectCode := UgeFxCmd;
1579 Pat^[RowIdx].EffectParams.Value := UgeFxVal;
1580 end;
1581
1582 Break; // fur2uge only emits the first present effect column
1583 end;
1584 end;
1585 end;
1586 end;
1587
1588 // Instruments — create hUGETracker instruments from the deduped fur lists
1589 for I := 0 to System.Length(PulseInsts) - 1 do begin
1590 FurInst := Reader.Instruments[PulseInsts[I]];
1591 HInst := @Result.Instruments.Duty[I + 1];
1592 HInst^.Type_ := itSquare;
1593 HInst^.Name := FurInst.Name;
1594 HInst^.InitialVolume := FurInst.GB.EnvVol and $F;
1595 if FurInst.GB.EnvDir = 1 then
1596 HInst^.VolSweepDirection := stUp
1597 else
1598 HInst^.VolSweepDirection := stDown;
1599 HInst^.VolSweepAmount := FurInst.GB.EnvLen and $7;
1600 HInst^.Length := FurInst.GB.SndLen;
1601 HInst^.LengthEnabled := HInst^.Length < $3F;
1602 if not HInst^.LengthEnabled then HInst^.Length := $3F;
1603 if (System.Length(FurInst.GB.HWSeq) > 0)
1604 and (FurInst.GB.HWSeq[0].CmdType = 1) then begin
1605 HInst^.SweepTime := FurInst.GB.HWSeq[0].SweepSpeed;
1606 if FurInst.GB.HWSeq[0].SweepDir = 1 then
1607 HInst^.SweepIncDec := stUp
1608 else
1609 HInst^.SweepIncDec := stDown;
1610 HInst^.SweepShift := FurInst.GB.HWSeq[0].ShiftVal;
1611 end;
1612 // Duty cycle from first DUTY macro value, if any
1613 HInst^.Duty := 2;
1614 for J := 0 to System.Length(FurInst.Macros) - 1 do
1615 if FurInst.Macros[J].Code = MC_DUTY then begin
1616 if System.Length(FurInst.Macros[J].Data) > 0 then
1617 HInst^.Duty := FurInst.Macros[J].Data[0] and $3;
1618 Break;
1619 end;
1620 // Overwrite initial volume if a VOL macro is present
1621 for J := 0 to System.Length(FurInst.Macros) - 1 do
1622 if FurInst.Macros[J].Code = MC_VOL then begin
1623 if System.Length(FurInst.Macros[J].Data) > 0 then
1624 HInst^.InitialVolume := FurInst.Macros[J].Data[0] and $F;
1625 Break;
1626 end;
1627 ApplyMacrosToSubpattern(HInst^.Subpattern, FurInst, 1);
1628 HInst^.SubpatternEnabled := False;
1629 for J := 0 to System.Length(FurInst.Macros) - 1 do
1630 if System.Length(FurInst.Macros[J].Data) > 1 then begin
1631 HInst^.SubpatternEnabled := True;
1632 Break;
1633 end;
1634 end;
1635
1636 for I := 0 to System.Length(WaveInsts) - 1 do begin
1637 FurInst := Reader.Instruments[WaveInsts[I]];
1638 HInst := @Result.Instruments.Wave[I + 1];
1639 HInst^.Type_ := itWave;
1640 HInst^.Name := FurInst.Name;
1641 HInst^.OutputLevel := 1;
1642 HInst^.Length := FurInst.GB.SndLen;
1643 HInst^.LengthEnabled := HInst^.Length < $3F;
1644 if not HInst^.LengthEnabled then HInst^.Length := $3F;
1645 // Wave index: WS's first wave, or first WAVE macro value
1646 HInst^.Waveform := 0;
1647 if FurInst.WS.Present and FurInst.WS.Enabled then
1648 HInst^.Waveform := FurInst.WS.FirstWave;
1649 for J := 0 to System.Length(FurInst.Macros) - 1 do
1650 if FurInst.Macros[J].Code = MC_WAVE then begin
1651 if System.Length(FurInst.Macros[J].Data) > 0 then
1652 HInst^.Waveform := FurInst.Macros[J].Data[0];
1653 Break;
1654 end;
1655 for J := 0 to System.Length(FurInst.Macros) - 1 do
1656 if FurInst.Macros[J].Code = MC_VOL then begin
1657 if System.Length(FurInst.Macros[J].Data) > 0 then
1658 HInst^.OutputLevel := FurInst.Macros[J].Data[0] and $3;
1659 Break;
1660 end;
1661 ApplyMacrosToSubpattern(HInst^.Subpattern, FurInst, 1);
1662 HInst^.SubpatternEnabled := False;
1663 for J := 0 to System.Length(FurInst.Macros) - 1 do
1664 if System.Length(FurInst.Macros[J].Data) > 1 then begin
1665 HInst^.SubpatternEnabled := True;
1666 Break;
1667 end;
1668 end;
1669
1670 for I := 0 to System.Length(NoiseInsts) - 1 do begin
1671 FurInst := Reader.Instruments[NoiseInsts[I]];
1672 HInst := @Result.Instruments.Noise[I + 1];
1673 HInst^.Type_ := itNoise;
1674 HInst^.Name := FurInst.Name;
1675 HInst^.InitialVolume := FurInst.GB.EnvVol and $F;
1676 // Fur2uge quirk: noise always emits stDown
1677 HInst^.VolSweepDirection := stDown;
1678 HInst^.VolSweepAmount := FurInst.GB.EnvLen and $7;
1679 HInst^.Length := FurInst.GB.SndLen;
1680 HInst^.LengthEnabled := HInst^.Length < $3F;
1681 if not HInst^.LengthEnabled then HInst^.Length := $3F;
1682 HInst^.CounterStep := swFifteen;
1683 ApplyMacrosToSubpattern(HInst^.Subpattern, FurInst, 1);
1684 HInst^.SubpatternEnabled := False;
1685 for J := 0 to System.Length(FurInst.Macros) - 1 do
1686 if System.Length(FurInst.Macros[J].Data) > 1 then begin
1687 HInst^.SubpatternEnabled := True;
1688 Break;
1689 end;
1690 end;
1691 finally
1692 FurPointerMap.Free;
1693 Reader.Free;
1694 end;
1695 end;
1696
1697 end.
Modifiedsrc/hUGETracker.lpi +6−1
@@ -203,7 +203,7 @@
203 <PackageName Value="LCL"/> 203 <PackageName Value="LCL"/>
204 </Item5> 204 </Item5>
205 </RequiredPackages> 205 </RequiredPackages>
206 <Units Count="28"> 206 <Units Count="29">
207 <Unit0> 207 <Unit0>
208 <Filename Value="hUGETracker.lpr"/> 208 <Filename Value="hUGETracker.lpr"/>
209 <IsPartOfProject Value="True"/> 209 <IsPartOfProject Value="True"/>
@@ -351,6 +351,11 @@
351 <Filename Value="vars.pas"/> 351 <Filename Value="vars.pas"/>
352 <IsPartOfProject Value="True"/> 352 <IsPartOfProject Value="True"/>
353 </Unit27> 353 </Unit27>
354 <Unit28>
355 <Filename Value="furimport.pas"/>
356 <IsPartOfProject Value="True"/>
357 <UnitName Value="FurImport"/>
358 </Unit28>
354 </Units> 359 </Units>
355 </ProjectOptions> 360 </ProjectOptions>
356 <CompilerOptions> 361 <CompilerOptions>
Modifiedsrc/tracker.lfm +10−0
@@ -2090,6 +2090,10 @@ object frmTracker: TfrmTracker
2090 ImageIndex = 86 2090 ImageIndex = 86
2091 OnClick = MenuItem55Click 2091 OnClick = MenuItem55Click
2092 end 2092 end
2093 object MenuItem60: TMenuItem
2094 Caption = 'Import Furnace FUR ...'
2095 OnClick = MenuItem60Click
2096 end
2093 object MenuItem35: TMenuItem 2097 object MenuItem35: TMenuItem
2094 Caption = '-' 2098 Caption = '-'
2095 end 2099 end
@@ -3216,4 +3220,10 @@ object frmTracker: TfrmTracker
3216 Left = 629 3220 Left = 629
3217 Top = 85 3221 Top = 85
3218 end 3222 end
3223 object FUROpenDialog: TOpenDialog
3224 DefaultExt = '.fur'
3225 Filter = 'Furnace Tracker modules|*.fur'
3226 Left = 629
3227 Top = 138
3228 end
3219 end 3229 end
Modifiedsrc/tracker.pas +30−1
@@ -10,7 +10,7 @@ uses
10 about_hugetracker, TrackerGrid, lclintf, lmessages, Buttons, Grids, DBCtrls, 10 about_hugetracker, TrackerGrid, lclintf, lmessages, Buttons, Grids, DBCtrls,
11 HugeDatatypes, LCLType, Clipbrd, RackCtls, Codegen, SymParser, options, 11 HugeDatatypes, LCLType, Clipbrd, RackCtls, Codegen, SymParser, options,
12 bgrabitmap, effecteditor, RenderToWave, modimport, mainloop, strutils, 12 bgrabitmap, effecteditor, RenderToWave, modimport, mainloop, strutils,
13 Types, Keymap, hUGESettings, vgm, TBMImport, InstrumentPreview, findreplace; 13 Types, Keymap, hUGESettings, vgm, TBMImport, FurImport, InstrumentPreview, findreplace;
14 14
15 // TODO: Move to config file? 15 // TODO: Move to config file?
16 const 16 const
@@ -51,6 +51,7 @@ type
51 RevertMenuItem: TMenuItem; 51 RevertMenuItem: TMenuItem;
52 Splitter2: TSplitter; 52 Splitter2: TSplitter;
53 TBMOpenDialog: TOpenDialog; 53 TBMOpenDialog: TOpenDialog;
54 FUROpenDialog: TOpenDialog;
54 ToolButton11: TToolButton; 55 ToolButton11: TToolButton;
55 LoopSongToolButton: TToolButton; 56 LoopSongToolButton: TToolButton;
56 ToolButton12: TToolButton; 57 ToolButton12: TToolButton;
@@ -305,6 +306,7 @@ type
305 procedure MenuItem15Click(Sender: TObject); 306 procedure MenuItem15Click(Sender: TObject);
306 procedure MenuItem26Click(Sender: TObject); 307 procedure MenuItem26Click(Sender: TObject);
307 procedure MenuItem55Click(Sender: TObject); 308 procedure MenuItem55Click(Sender: TObject);
309 procedure MenuItem60Click(Sender: TObject);
308 procedure MenuItem56Click(Sender: TObject); 310 procedure MenuItem56Click(Sender: TObject);
309 procedure OrderEditStringGridMouseDown(Sender: TObject; 311 procedure OrderEditStringGridMouseDown(Sender: TObject;
310 Button: TMouseButton; Shift: TShiftState; X, Y: Integer); 312 Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
@@ -2102,6 +2104,33 @@ begin
2102 (ActiveControl as TTrackerGrid).ChangeSelectionInstrument; 2104 (ActiveControl as TTrackerGrid).ChangeSelectionInstrument;
2103 end; 2105 end;
2104 2106
2107 procedure TfrmTracker.MenuItem60Click(Sender: TObject);
2108 var
2109 Stream: TStream;
2110 NewSong: TSong;
2111 begin
2112 if not CheckUnsavedChanges then Exit;
2113
2114 if FUROpenDialog.Execute then begin
2115 Stream := nil;
2116 try
2117 try
2118 Stream := TFileStream.Create(FUROpenDialog.FileName, fmOpenRead);
2119 NewSong := LoadSongFromFurStream(Stream);
2120 DestroySong(Song);
2121 Song := NewSong;
2122 UpdateUIAfterLoad(FUROpenDialog.FileName);
2123 finally
2124 if Assigned(Stream) then Stream.Free;
2125 end;
2126 except
2127 on E: EFurException do
2128 MessageDlg('There was an error loading the file. ' + E.Message,
2129 mtError, [mbOK], 0);
2130 end;
2131 end;
2132 end;
2133
2105 procedure TfrmTracker.OrderEditStringGridMouseDown(Sender: TObject; 2134 procedure TfrmTracker.OrderEditStringGridMouseDown(Sender: TObject;
2106 Button: TMouseButton; Shift: TShiftState; X, Y: Integer); 2135 Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
2107 begin 2136 begin