OSDN -- Développer et télécharger des logiciels Open Source
Traduction statut du Français translation status for fr
  • R/O
  • SSH
Fork

Commit

Frequently used words (click to add to your profile)

javac++androidlinuxc#windowsobjective-ccocoa誰得qtpythonphprubygameguibathyscaphec計画中(planning stage)翻訳omegatframeworktwitterdomtestvb.netdirectxゲームエンジンbtronarduinopreviewer

VGM playback library for Common Lisp


Commit MetaInfo

Révision98c8a177535578ebde97c5052456e395662d4d34 (tree)
l'heure2023-05-24 17:52:21
AuteurRemilia Scarlet <remilia@post...>
CommiterRemilia Scarlet

Message de Log

Initial import

Change Summary

Modification

diff -r 000000000000 -r 98c8a1775355 LICENSE
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/LICENSE Wed May 24 02:52:21 2023 -0600
@@ -0,0 +1,661 @@
1+ GNU AFFERO GENERAL PUBLIC LICENSE
2+ Version 3, 19 November 2007
3+
4+ Copyright (C) 2007 Free Software Foundation, Inc. <https://fsf.org/>
5+ Everyone is permitted to copy and distribute verbatim copies
6+ of this license document, but changing it is not allowed.
7+
8+ Preamble
9+
10+ The GNU Affero General Public License is a free, copyleft license for
11+software and other kinds of works, specifically designed to ensure
12+cooperation with the community in the case of network server software.
13+
14+ The licenses for most software and other practical works are designed
15+to take away your freedom to share and change the works. By contrast,
16+our General Public Licenses are intended to guarantee your freedom to
17+share and change all versions of a program--to make sure it remains free
18+software for all its users.
19+
20+ When we speak of free software, we are referring to freedom, not
21+price. Our General Public Licenses are designed to make sure that you
22+have the freedom to distribute copies of free software (and charge for
23+them if you wish), that you receive source code or can get it if you
24+want it, that you can change the software or use pieces of it in new
25+free programs, and that you know you can do these things.
26+
27+ Developers that use our General Public Licenses protect your rights
28+with two steps: (1) assert copyright on the software, and (2) offer
29+you this License which gives you legal permission to copy, distribute
30+and/or modify the software.
31+
32+ A secondary benefit of defending all users' freedom is that
33+improvements made in alternate versions of the program, if they
34+receive widespread use, become available for other developers to
35+incorporate. Many developers of free software are heartened and
36+encouraged by the resulting cooperation. However, in the case of
37+software used on network servers, this result may fail to come about.
38+The GNU General Public License permits making a modified version and
39+letting the public access it on a server without ever releasing its
40+source code to the public.
41+
42+ The GNU Affero General Public License is designed specifically to
43+ensure that, in such cases, the modified source code becomes available
44+to the community. It requires the operator of a network server to
45+provide the source code of the modified version running there to the
46+users of that server. Therefore, public use of a modified version, on
47+a publicly accessible server, gives the public access to the source
48+code of the modified version.
49+
50+ An older license, called the Affero General Public License and
51+published by Affero, was designed to accomplish similar goals. This is
52+a different license, not a version of the Affero GPL, but Affero has
53+released a new version of the Affero GPL which permits relicensing under
54+this license.
55+
56+ The precise terms and conditions for copying, distribution and
57+modification follow.
58+
59+ TERMS AND CONDITIONS
60+
61+ 0. Definitions.
62+
63+ "This License" refers to version 3 of the GNU Affero General Public License.
64+
65+ "Copyright" also means copyright-like laws that apply to other kinds of
66+works, such as semiconductor masks.
67+
68+ "The Program" refers to any copyrightable work licensed under this
69+License. Each licensee is addressed as "you". "Licensees" and
70+"recipients" may be individuals or organizations.
71+
72+ To "modify" a work means to copy from or adapt all or part of the work
73+in a fashion requiring copyright permission, other than the making of an
74+exact copy. The resulting work is called a "modified version" of the
75+earlier work or a work "based on" the earlier work.
76+
77+ A "covered work" means either the unmodified Program or a work based
78+on the Program.
79+
80+ To "propagate" a work means to do anything with it that, without
81+permission, would make you directly or secondarily liable for
82+infringement under applicable copyright law, except executing it on a
83+computer or modifying a private copy. Propagation includes copying,
84+distribution (with or without modification), making available to the
85+public, and in some countries other activities as well.
86+
87+ To "convey" a work means any kind of propagation that enables other
88+parties to make or receive copies. Mere interaction with a user through
89+a computer network, with no transfer of a copy, is not conveying.
90+
91+ An interactive user interface displays "Appropriate Legal Notices"
92+to the extent that it includes a convenient and prominently visible
93+feature that (1) displays an appropriate copyright notice, and (2)
94+tells the user that there is no warranty for the work (except to the
95+extent that warranties are provided), that licensees may convey the
96+work under this License, and how to view a copy of this License. If
97+the interface presents a list of user commands or options, such as a
98+menu, a prominent item in the list meets this criterion.
99+
100+ 1. Source Code.
101+
102+ The "source code" for a work means the preferred form of the work
103+for making modifications to it. "Object code" means any non-source
104+form of a work.
105+
106+ A "Standard Interface" means an interface that either is an official
107+standard defined by a recognized standards body, or, in the case of
108+interfaces specified for a particular programming language, one that
109+is widely used among developers working in that language.
110+
111+ The "System Libraries" of an executable work include anything, other
112+than the work as a whole, that (a) is included in the normal form of
113+packaging a Major Component, but which is not part of that Major
114+Component, and (b) serves only to enable use of the work with that
115+Major Component, or to implement a Standard Interface for which an
116+implementation is available to the public in source code form. A
117+"Major Component", in this context, means a major essential component
118+(kernel, window system, and so on) of the specific operating system
119+(if any) on which the executable work runs, or a compiler used to
120+produce the work, or an object code interpreter used to run it.
121+
122+ The "Corresponding Source" for a work in object code form means all
123+the source code needed to generate, install, and (for an executable
124+work) run the object code and to modify the work, including scripts to
125+control those activities. However, it does not include the work's
126+System Libraries, or general-purpose tools or generally available free
127+programs which are used unmodified in performing those activities but
128+which are not part of the work. For example, Corresponding Source
129+includes interface definition files associated with source files for
130+the work, and the source code for shared libraries and dynamically
131+linked subprograms that the work is specifically designed to require,
132+such as by intimate data communication or control flow between those
133+subprograms and other parts of the work.
134+
135+ The Corresponding Source need not include anything that users
136+can regenerate automatically from other parts of the Corresponding
137+Source.
138+
139+ The Corresponding Source for a work in source code form is that
140+same work.
141+
142+ 2. Basic Permissions.
143+
144+ All rights granted under this License are granted for the term of
145+copyright on the Program, and are irrevocable provided the stated
146+conditions are met. This License explicitly affirms your unlimited
147+permission to run the unmodified Program. The output from running a
148+covered work is covered by this License only if the output, given its
149+content, constitutes a covered work. This License acknowledges your
150+rights of fair use or other equivalent, as provided by copyright law.
151+
152+ You may make, run and propagate covered works that you do not
153+convey, without conditions so long as your license otherwise remains
154+in force. You may convey covered works to others for the sole purpose
155+of having them make modifications exclusively for you, or provide you
156+with facilities for running those works, provided that you comply with
157+the terms of this License in conveying all material for which you do
158+not control copyright. Those thus making or running the covered works
159+for you must do so exclusively on your behalf, under your direction
160+and control, on terms that prohibit them from making any copies of
161+your copyrighted material outside their relationship with you.
162+
163+ Conveying under any other circumstances is permitted solely under
164+the conditions stated below. Sublicensing is not allowed; section 10
165+makes it unnecessary.
166+
167+ 3. Protecting Users' Legal Rights From Anti-Circumvention Law.
168+
169+ No covered work shall be deemed part of an effective technological
170+measure under any applicable law fulfilling obligations under article
171+11 of the WIPO copyright treaty adopted on 20 December 1996, or
172+similar laws prohibiting or restricting circumvention of such
173+measures.
174+
175+ When you convey a covered work, you waive any legal power to forbid
176+circumvention of technological measures to the extent such circumvention
177+is effected by exercising rights under this License with respect to
178+the covered work, and you disclaim any intention to limit operation or
179+modification of the work as a means of enforcing, against the work's
180+users, your or third parties' legal rights to forbid circumvention of
181+technological measures.
182+
183+ 4. Conveying Verbatim Copies.
184+
185+ You may convey verbatim copies of the Program's source code as you
186+receive it, in any medium, provided that you conspicuously and
187+appropriately publish on each copy an appropriate copyright notice;
188+keep intact all notices stating that this License and any
189+non-permissive terms added in accord with section 7 apply to the code;
190+keep intact all notices of the absence of any warranty; and give all
191+recipients a copy of this License along with the Program.
192+
193+ You may charge any price or no price for each copy that you convey,
194+and you may offer support or warranty protection for a fee.
195+
196+ 5. Conveying Modified Source Versions.
197+
198+ You may convey a work based on the Program, or the modifications to
199+produce it from the Program, in the form of source code under the
200+terms of section 4, provided that you also meet all of these conditions:
201+
202+ a) The work must carry prominent notices stating that you modified
203+ it, and giving a relevant date.
204+
205+ b) The work must carry prominent notices stating that it is
206+ released under this License and any conditions added under section
207+ 7. This requirement modifies the requirement in section 4 to
208+ "keep intact all notices".
209+
210+ c) You must license the entire work, as a whole, under this
211+ License to anyone who comes into possession of a copy. This
212+ License will therefore apply, along with any applicable section 7
213+ additional terms, to the whole of the work, and all its parts,
214+ regardless of how they are packaged. This License gives no
215+ permission to license the work in any other way, but it does not
216+ invalidate such permission if you have separately received it.
217+
218+ d) If the work has interactive user interfaces, each must display
219+ Appropriate Legal Notices; however, if the Program has interactive
220+ interfaces that do not display Appropriate Legal Notices, your
221+ work need not make them do so.
222+
223+ A compilation of a covered work with other separate and independent
224+works, which are not by their nature extensions of the covered work,
225+and which are not combined with it such as to form a larger program,
226+in or on a volume of a storage or distribution medium, is called an
227+"aggregate" if the compilation and its resulting copyright are not
228+used to limit the access or legal rights of the compilation's users
229+beyond what the individual works permit. Inclusion of a covered work
230+in an aggregate does not cause this License to apply to the other
231+parts of the aggregate.
232+
233+ 6. Conveying Non-Source Forms.
234+
235+ You may convey a covered work in object code form under the terms
236+of sections 4 and 5, provided that you also convey the
237+machine-readable Corresponding Source under the terms of this License,
238+in one of these ways:
239+
240+ a) Convey the object code in, or embodied in, a physical product
241+ (including a physical distribution medium), accompanied by the
242+ Corresponding Source fixed on a durable physical medium
243+ customarily used for software interchange.
244+
245+ b) Convey the object code in, or embodied in, a physical product
246+ (including a physical distribution medium), accompanied by a
247+ written offer, valid for at least three years and valid for as
248+ long as you offer spare parts or customer support for that product
249+ model, to give anyone who possesses the object code either (1) a
250+ copy of the Corresponding Source for all the software in the
251+ product that is covered by this License, on a durable physical
252+ medium customarily used for software interchange, for a price no
253+ more than your reasonable cost of physically performing this
254+ conveying of source, or (2) access to copy the
255+ Corresponding Source from a network server at no charge.
256+
257+ c) Convey individual copies of the object code with a copy of the
258+ written offer to provide the Corresponding Source. This
259+ alternative is allowed only occasionally and noncommercially, and
260+ only if you received the object code with such an offer, in accord
261+ with subsection 6b.
262+
263+ d) Convey the object code by offering access from a designated
264+ place (gratis or for a charge), and offer equivalent access to the
265+ Corresponding Source in the same way through the same place at no
266+ further charge. You need not require recipients to copy the
267+ Corresponding Source along with the object code. If the place to
268+ copy the object code is a network server, the Corresponding Source
269+ may be on a different server (operated by you or a third party)
270+ that supports equivalent copying facilities, provided you maintain
271+ clear directions next to the object code saying where to find the
272+ Corresponding Source. Regardless of what server hosts the
273+ Corresponding Source, you remain obligated to ensure that it is
274+ available for as long as needed to satisfy these requirements.
275+
276+ e) Convey the object code using peer-to-peer transmission, provided
277+ you inform other peers where the object code and Corresponding
278+ Source of the work are being offered to the general public at no
279+ charge under subsection 6d.
280+
281+ A separable portion of the object code, whose source code is excluded
282+from the Corresponding Source as a System Library, need not be
283+included in conveying the object code work.
284+
285+ A "User Product" is either (1) a "consumer product", which means any
286+tangible personal property which is normally used for personal, family,
287+or household purposes, or (2) anything designed or sold for incorporation
288+into a dwelling. In determining whether a product is a consumer product,
289+doubtful cases shall be resolved in favor of coverage. For a particular
290+product received by a particular user, "normally used" refers to a
291+typical or common use of that class of product, regardless of the status
292+of the particular user or of the way in which the particular user
293+actually uses, or expects or is expected to use, the product. A product
294+is a consumer product regardless of whether the product has substantial
295+commercial, industrial or non-consumer uses, unless such uses represent
296+the only significant mode of use of the product.
297+
298+ "Installation Information" for a User Product means any methods,
299+procedures, authorization keys, or other information required to install
300+and execute modified versions of a covered work in that User Product from
301+a modified version of its Corresponding Source. The information must
302+suffice to ensure that the continued functioning of the modified object
303+code is in no case prevented or interfered with solely because
304+modification has been made.
305+
306+ If you convey an object code work under this section in, or with, or
307+specifically for use in, a User Product, and the conveying occurs as
308+part of a transaction in which the right of possession and use of the
309+User Product is transferred to the recipient in perpetuity or for a
310+fixed term (regardless of how the transaction is characterized), the
311+Corresponding Source conveyed under this section must be accompanied
312+by the Installation Information. But this requirement does not apply
313+if neither you nor any third party retains the ability to install
314+modified object code on the User Product (for example, the work has
315+been installed in ROM).
316+
317+ The requirement to provide Installation Information does not include a
318+requirement to continue to provide support service, warranty, or updates
319+for a work that has been modified or installed by the recipient, or for
320+the User Product in which it has been modified or installed. Access to a
321+network may be denied when the modification itself materially and
322+adversely affects the operation of the network or violates the rules and
323+protocols for communication across the network.
324+
325+ Corresponding Source conveyed, and Installation Information provided,
326+in accord with this section must be in a format that is publicly
327+documented (and with an implementation available to the public in
328+source code form), and must require no special password or key for
329+unpacking, reading or copying.
330+
331+ 7. Additional Terms.
332+
333+ "Additional permissions" are terms that supplement the terms of this
334+License by making exceptions from one or more of its conditions.
335+Additional permissions that are applicable to the entire Program shall
336+be treated as though they were included in this License, to the extent
337+that they are valid under applicable law. If additional permissions
338+apply only to part of the Program, that part may be used separately
339+under those permissions, but the entire Program remains governed by
340+this License without regard to the additional permissions.
341+
342+ When you convey a copy of a covered work, you may at your option
343+remove any additional permissions from that copy, or from any part of
344+it. (Additional permissions may be written to require their own
345+removal in certain cases when you modify the work.) You may place
346+additional permissions on material, added by you to a covered work,
347+for which you have or can give appropriate copyright permission.
348+
349+ Notwithstanding any other provision of this License, for material you
350+add to a covered work, you may (if authorized by the copyright holders of
351+that material) supplement the terms of this License with terms:
352+
353+ a) Disclaiming warranty or limiting liability differently from the
354+ terms of sections 15 and 16 of this License; or
355+
356+ b) Requiring preservation of specified reasonable legal notices or
357+ author attributions in that material or in the Appropriate Legal
358+ Notices displayed by works containing it; or
359+
360+ c) Prohibiting misrepresentation of the origin of that material, or
361+ requiring that modified versions of such material be marked in
362+ reasonable ways as different from the original version; or
363+
364+ d) Limiting the use for publicity purposes of names of licensors or
365+ authors of the material; or
366+
367+ e) Declining to grant rights under trademark law for use of some
368+ trade names, trademarks, or service marks; or
369+
370+ f) Requiring indemnification of licensors and authors of that
371+ material by anyone who conveys the material (or modified versions of
372+ it) with contractual assumptions of liability to the recipient, for
373+ any liability that these contractual assumptions directly impose on
374+ those licensors and authors.
375+
376+ All other non-permissive additional terms are considered "further
377+restrictions" within the meaning of section 10. If the Program as you
378+received it, or any part of it, contains a notice stating that it is
379+governed by this License along with a term that is a further
380+restriction, you may remove that term. If a license document contains
381+a further restriction but permits relicensing or conveying under this
382+License, you may add to a covered work material governed by the terms
383+of that license document, provided that the further restriction does
384+not survive such relicensing or conveying.
385+
386+ If you add terms to a covered work in accord with this section, you
387+must place, in the relevant source files, a statement of the
388+additional terms that apply to those files, or a notice indicating
389+where to find the applicable terms.
390+
391+ Additional terms, permissive or non-permissive, may be stated in the
392+form of a separately written license, or stated as exceptions;
393+the above requirements apply either way.
394+
395+ 8. Termination.
396+
397+ You may not propagate or modify a covered work except as expressly
398+provided under this License. Any attempt otherwise to propagate or
399+modify it is void, and will automatically terminate your rights under
400+this License (including any patent licenses granted under the third
401+paragraph of section 11).
402+
403+ However, if you cease all violation of this License, then your
404+license from a particular copyright holder is reinstated (a)
405+provisionally, unless and until the copyright holder explicitly and
406+finally terminates your license, and (b) permanently, if the copyright
407+holder fails to notify you of the violation by some reasonable means
408+prior to 60 days after the cessation.
409+
410+ Moreover, your license from a particular copyright holder is
411+reinstated permanently if the copyright holder notifies you of the
412+violation by some reasonable means, this is the first time you have
413+received notice of violation of this License (for any work) from that
414+copyright holder, and you cure the violation prior to 30 days after
415+your receipt of the notice.
416+
417+ Termination of your rights under this section does not terminate the
418+licenses of parties who have received copies or rights from you under
419+this License. If your rights have been terminated and not permanently
420+reinstated, you do not qualify to receive new licenses for the same
421+material under section 10.
422+
423+ 9. Acceptance Not Required for Having Copies.
424+
425+ You are not required to accept this License in order to receive or
426+run a copy of the Program. Ancillary propagation of a covered work
427+occurring solely as a consequence of using peer-to-peer transmission
428+to receive a copy likewise does not require acceptance. However,
429+nothing other than this License grants you permission to propagate or
430+modify any covered work. These actions infringe copyright if you do
431+not accept this License. Therefore, by modifying or propagating a
432+covered work, you indicate your acceptance of this License to do so.
433+
434+ 10. Automatic Licensing of Downstream Recipients.
435+
436+ Each time you convey a covered work, the recipient automatically
437+receives a license from the original licensors, to run, modify and
438+propagate that work, subject to this License. You are not responsible
439+for enforcing compliance by third parties with this License.
440+
441+ An "entity transaction" is a transaction transferring control of an
442+organization, or substantially all assets of one, or subdividing an
443+organization, or merging organizations. If propagation of a covered
444+work results from an entity transaction, each party to that
445+transaction who receives a copy of the work also receives whatever
446+licenses to the work the party's predecessor in interest had or could
447+give under the previous paragraph, plus a right to possession of the
448+Corresponding Source of the work from the predecessor in interest, if
449+the predecessor has it or can get it with reasonable efforts.
450+
451+ You may not impose any further restrictions on the exercise of the
452+rights granted or affirmed under this License. For example, you may
453+not impose a license fee, royalty, or other charge for exercise of
454+rights granted under this License, and you may not initiate litigation
455+(including a cross-claim or counterclaim in a lawsuit) alleging that
456+any patent claim is infringed by making, using, selling, offering for
457+sale, or importing the Program or any portion of it.
458+
459+ 11. Patents.
460+
461+ A "contributor" is a copyright holder who authorizes use under this
462+License of the Program or a work on which the Program is based. The
463+work thus licensed is called the contributor's "contributor version".
464+
465+ A contributor's "essential patent claims" are all patent claims
466+owned or controlled by the contributor, whether already acquired or
467+hereafter acquired, that would be infringed by some manner, permitted
468+by this License, of making, using, or selling its contributor version,
469+but do not include claims that would be infringed only as a
470+consequence of further modification of the contributor version. For
471+purposes of this definition, "control" includes the right to grant
472+patent sublicenses in a manner consistent with the requirements of
473+this License.
474+
475+ Each contributor grants you a non-exclusive, worldwide, royalty-free
476+patent license under the contributor's essential patent claims, to
477+make, use, sell, offer for sale, import and otherwise run, modify and
478+propagate the contents of its contributor version.
479+
480+ In the following three paragraphs, a "patent license" is any express
481+agreement or commitment, however denominated, not to enforce a patent
482+(such as an express permission to practice a patent or covenant not to
483+sue for patent infringement). To "grant" such a patent license to a
484+party means to make such an agreement or commitment not to enforce a
485+patent against the party.
486+
487+ If you convey a covered work, knowingly relying on a patent license,
488+and the Corresponding Source of the work is not available for anyone
489+to copy, free of charge and under the terms of this License, through a
490+publicly available network server or other readily accessible means,
491+then you must either (1) cause the Corresponding Source to be so
492+available, or (2) arrange to deprive yourself of the benefit of the
493+patent license for this particular work, or (3) arrange, in a manner
494+consistent with the requirements of this License, to extend the patent
495+license to downstream recipients. "Knowingly relying" means you have
496+actual knowledge that, but for the patent license, your conveying the
497+covered work in a country, or your recipient's use of the covered work
498+in a country, would infringe one or more identifiable patents in that
499+country that you have reason to believe are valid.
500+
501+ If, pursuant to or in connection with a single transaction or
502+arrangement, you convey, or propagate by procuring conveyance of, a
503+covered work, and grant a patent license to some of the parties
504+receiving the covered work authorizing them to use, propagate, modify
505+or convey a specific copy of the covered work, then the patent license
506+you grant is automatically extended to all recipients of the covered
507+work and works based on it.
508+
509+ A patent license is "discriminatory" if it does not include within
510+the scope of its coverage, prohibits the exercise of, or is
511+conditioned on the non-exercise of one or more of the rights that are
512+specifically granted under this License. You may not convey a covered
513+work if you are a party to an arrangement with a third party that is
514+in the business of distributing software, under which you make payment
515+to the third party based on the extent of your activity of conveying
516+the work, and under which the third party grants, to any of the
517+parties who would receive the covered work from you, a discriminatory
518+patent license (a) in connection with copies of the covered work
519+conveyed by you (or copies made from those copies), or (b) primarily
520+for and in connection with specific products or compilations that
521+contain the covered work, unless you entered into that arrangement,
522+or that patent license was granted, prior to 28 March 2007.
523+
524+ Nothing in this License shall be construed as excluding or limiting
525+any implied license or other defenses to infringement that may
526+otherwise be available to you under applicable patent law.
527+
528+ 12. No Surrender of Others' Freedom.
529+
530+ If conditions are imposed on you (whether by court order, agreement or
531+otherwise) that contradict the conditions of this License, they do not
532+excuse you from the conditions of this License. If you cannot convey a
533+covered work so as to satisfy simultaneously your obligations under this
534+License and any other pertinent obligations, then as a consequence you may
535+not convey it at all. For example, if you agree to terms that obligate you
536+to collect a royalty for further conveying from those to whom you convey
537+the Program, the only way you could satisfy both those terms and this
538+License would be to refrain entirely from conveying the Program.
539+
540+ 13. Remote Network Interaction; Use with the GNU General Public License.
541+
542+ Notwithstanding any other provision of this License, if you modify the
543+Program, your modified version must prominently offer all users
544+interacting with it remotely through a computer network (if your version
545+supports such interaction) an opportunity to receive the Corresponding
546+Source of your version by providing access to the Corresponding Source
547+from a network server at no charge, through some standard or customary
548+means of facilitating copying of software. This Corresponding Source
549+shall include the Corresponding Source for any work covered by version 3
550+of the GNU General Public License that is incorporated pursuant to the
551+following paragraph.
552+
553+ Notwithstanding any other provision of this License, you have
554+permission to link or combine any covered work with a work licensed
555+under version 3 of the GNU General Public License into a single
556+combined work, and to convey the resulting work. The terms of this
557+License will continue to apply to the part which is the covered work,
558+but the work with which it is combined will remain governed by version
559+3 of the GNU General Public License.
560+
561+ 14. Revised Versions of this License.
562+
563+ The Free Software Foundation may publish revised and/or new versions of
564+the GNU Affero General Public License from time to time. Such new versions
565+will be similar in spirit to the present version, but may differ in detail to
566+address new problems or concerns.
567+
568+ Each version is given a distinguishing version number. If the
569+Program specifies that a certain numbered version of the GNU Affero General
570+Public License "or any later version" applies to it, you have the
571+option of following the terms and conditions either of that numbered
572+version or of any later version published by the Free Software
573+Foundation. If the Program does not specify a version number of the
574+GNU Affero General Public License, you may choose any version ever published
575+by the Free Software Foundation.
576+
577+ If the Program specifies that a proxy can decide which future
578+versions of the GNU Affero General Public License can be used, that proxy's
579+public statement of acceptance of a version permanently authorizes you
580+to choose that version for the Program.
581+
582+ Later license versions may give you additional or different
583+permissions. However, no additional obligations are imposed on any
584+author or copyright holder as a result of your choosing to follow a
585+later version.
586+
587+ 15. Disclaimer of Warranty.
588+
589+ THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY
590+APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT
591+HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY
592+OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO,
593+THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
594+PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM
595+IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF
596+ALL NECESSARY SERVICING, REPAIR OR CORRECTION.
597+
598+ 16. Limitation of Liability.
599+
600+ IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
601+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS
602+THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY
603+GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE
604+USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF
605+DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD
606+PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS),
607+EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF
608+SUCH DAMAGES.
609+
610+ 17. Interpretation of Sections 15 and 16.
611+
612+ If the disclaimer of warranty and limitation of liability provided
613+above cannot be given local legal effect according to their terms,
614+reviewing courts shall apply local law that most closely approximates
615+an absolute waiver of all civil liability in connection with the
616+Program, unless a warranty or assumption of liability accompanies a
617+copy of the Program in return for a fee.
618+
619+ END OF TERMS AND CONDITIONS
620+
621+ How to Apply These Terms to Your New Programs
622+
623+ If you develop a new program, and you want it to be of the greatest
624+possible use to the public, the best way to achieve this is to make it
625+free software which everyone can redistribute and change under these terms.
626+
627+ To do so, attach the following notices to the program. It is safest
628+to attach them to the start of each source file to most effectively
629+state the exclusion of warranty; and each file should have at least
630+the "copyright" line and a pointer to where the full notice is found.
631+
632+ <one line to give the program's name and a brief idea of what it does.>
633+ Copyright (C) <year> <name of author>
634+
635+ This program is free software: you can redistribute it and/or modify
636+ it under the terms of the GNU Affero General Public License as published by
637+ the Free Software Foundation, either version 3 of the License, or
638+ (at your option) any later version.
639+
640+ This program is distributed in the hope that it will be useful,
641+ but WITHOUT ANY WARRANTY; without even the implied warranty of
642+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
643+ GNU Affero General Public License for more details.
644+
645+ You should have received a copy of the GNU Affero General Public License
646+ along with this program. If not, see <https://www.gnu.org/licenses/>.
647+
648+Also add information on how to contact you by electronic and paper mail.
649+
650+ If your software can interact with users remotely through a computer
651+network, you should also make sure that it provides a way for users to
652+get its source. For example, if your program is a web application, its
653+interface could display a "Source" link that leads users to an archive
654+of the code. There are many ways you could offer source, and different
655+solutions will be better for different programs; see section 13 for the
656+specific requirements.
657+
658+ You should also get your employer (if you work as a programmer) or school,
659+if any, to sign a "copyright disclaimer" for the program, if necessary.
660+For more information on this, and how to apply and follow the GNU AGPL, see
661+<https://www.gnu.org/licenses/>.
diff -r 000000000000 -r 98c8a1775355 satou.asd
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/satou.asd Wed May 24 02:52:21 2023 -0600
@@ -0,0 +1,54 @@
1+(require 'asdf)
2+(in-package :asdf-user)
3+
4+#-sbcl (error "SatouSynth only supports SBCL.")
5+
6+(defun %do-block-compile (thunk)
7+ #-(or satou-debug satou-verbose-debug)
8+ (apply thunk (when (uiop:featurep :sbcl) '(:block-compile t))))
9+
10+(asdf:defsystem satou
11+ :long-name "SatouSynth"
12+ :description "VGM playback library in pure Common Lisp"
13+ :version "0.1.0"
14+ :license "AGPLv3 (see LICENSE for details)"
15+
16+ :maintainer "Remilia Scarlet"
17+ :author "Remilia Scarlet"
18+
19+ :depends-on (:cl-sdm
20+ ;;:cffi
21+ ;;:waaf-cffi
22+ :chipz
23+ :flexi-streams
24+ :closer-mop)
25+
26+ :serial t
27+ :components
28+ ((:module
29+ "src"
30+ :components
31+ ((:file "package")
32+ (:file "common")
33+
34+ (:file "gd3-tag" :around-compile %do-block-compile)
35+ (:file "vgm-decompression" :around-compile %do-block-compile)
36+ (:file "vgmfile" :around-compile %do-block-compile)
37+ (:file "abstract-chip" :around-compile %do-block-compile)
38+
39+ (:module
40+ "chips"
41+ :components
42+ ((:file "common")
43+ (:file "emu-huc6280-ootake" :around-compile %do-block-compile)
44+ (:file "chip-huc6280" :around-compile %do-block-compile)
45+
46+ (:file "emu-c352-mame" :around-compile %do-block-compile)
47+ (:file "chip-c352" :around-compile %do-block-compile)
48+
49+ (:file "emu-ym2151-mame" :around-compile %do-block-compile)))
50+
51+ (:file "resampler" :around-compile %do-block-compile)
52+ (:file "dac-controller" :around-compile %do-block-compile)
53+ (:file "vgm-player-settings")
54+ (:file "vgm-player" :around-compile %do-block-compile)))))
diff -r 000000000000 -r 98c8a1775355 src/abstract-chip.lisp
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/abstract-chip.lisp Wed May 24 02:52:21 2023 -0600
@@ -0,0 +1,291 @@
1+;;;; SatouSynth
2+;;;; Copyright (C) 2023 Remilia Scarlet <remilia@posteo.jp>
3+;;;;
4+;;;; This program is free software: you can redistribute it and/or
5+;;;; modify it under the terms of the GNU Affero General Public
6+;;;; License as published by the Free Software Foundation, either
7+;;;; version 3 of the License, or (at your option) any later version.
8+;;;;
9+;;;; This program is distributed in the hope that it will be useful,
10+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
11+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12+;;;; Affero General Public License for more details.
13+;;;;
14+;;;; You should have received a copy of the GNU Affero General Public License
15+;;;; along with this program. If not, see <https://www.gnu.org/licenses/>.
16+(in-package :satou)
17+
18+(defgeneric chip-type (chip))
19+(defgeneric chip-name (chip))
20+(defgeneric chip-short-name (chip))
21+(defgeneric chip-id (chip))
22+(defgeneric chip-default-emu-core (chip))
23+(defgeneric chip-base-volume (chip))
24+(defgeneric chip-start (chip clock &optional flags))
25+(defgeneric chip-clock (chip))
26+(defgeneric chip-start-flags (chip vgm))
27+(defgeneric chip-update (chip outputs start samples))
28+(defgeneric chip-update-paired (chip outputs start samples))
29+(defgeneric chip-reset (chip))
30+(defgeneric chip-read (chip offset))
31+(defgeneric chip-write (chip offset data &optional port))
32+(defgeneric (setf chip-mute-mask) (value chip))
33+(defgeneric chip-write-dac (chip port command data))
34+(defgeneric (setf chip-stereo-mask) (value chip))
35+(defgeneric chip-volume-modifier (chip))
36+(defgeneric chip-init (chip vgm playback-sample-rate sampling-mode player-sample-rate &key emu-core flags))
37+(defgeneric chip-write-rom (chip rom-size data-start data-length rom-data))
38+
39+(defclass chip-flags ()
40+ ())
41+
42+(defclass abstract-chip ()
43+ ((sample-rate
44+ :initform 0
45+ :type t/uint32
46+ :accessor chip-sample-rate)
47+
48+ (player-sample-rate
49+ :initform 0
50+ :type t/uint32
51+ :reader chip-player-sample-rate)
52+
53+ (clock-from-header
54+ :initform 0
55+ :type t/uint32)
56+
57+ (volume
58+ :initform 0
59+ :type t/uint16
60+ :accessor chip-volume)
61+
62+ (resampler-type
63+ :initform :copy
64+ :type t/resampler-type
65+ :accessor chip-resampler-type)
66+
67+ (cur-sample-num
68+ :initform 0
69+ :type t/uint32)
70+
71+ (last-sample-num
72+ :initform 0
73+ :type t/uint32)
74+
75+ (next-sample-num
76+ :initform 0
77+ :type t/uint32)
78+
79+ (last-sample
80+ :initform (vector 0 0)
81+ :type t/sample)
82+
83+ (next-sample
84+ :initform (vector 0 0)
85+ :type t/sample)
86+
87+ (paired
88+ :initform nil
89+ :type (or null abstract-chip))
90+
91+ (is-paired?
92+ :initform nil
93+ :type boolean
94+ :reader chip-is-paired-p)
95+
96+ (core
97+ :initform :unknown
98+ :type keyword
99+ :reader chip-emu-core)
100+
101+ (emu
102+ :initform nil
103+ :reader chip-emu)
104+
105+ (update-fn
106+ :initform nil
107+ :type (or null function))))
108+
109+(defmethod chip-start-flags ((chip abstract-chip) vgm)
110+ (declare (ignore vgm))
111+ nil)
112+
113+(defmethod chip-update-paired ((chip abstract-chip) outputs start samples)
114+ (declare (ignore outputs start samples))
115+ nil)
116+
117+(defmethod chip-write-dac ((chip abstract-chip) (port integer) (command integer) (data integer))
118+ (chip-write chip command data (coerce-to-uint8 port)))
119+
120+(defmethod chip-volume-modifier ((chip abstract-chip))
121+ (slot-value chip 'volume))
122+
123+(defmethod chip-clock ((chip abstract-chip))
124+ (slot-value chip 'clock-from-header))
125+
126+(define-typed-fn get-chip-volume ((abstract-chip chip) (vgm-file vgm) (t/chip chip-type) (fixnum chip-count)
127+ &optional paired)
128+ (t/uint16)
129+ (declare (optimize (speed 3) (debug 1) (safety 1) (compilation-speed 0)))
130+ (check-type paired (or null t/chip))
131+
132+ (with-typed-slots ((vgm-file-header header)
133+ ((or null extra-header) extra-header)
134+ (gd3-tag gd3))
135+ vgm
136+ (let ((volume (chip-base-volume chip))
137+ (count chip-count))
138+ (declare (type t/uint16 volume))
139+
140+ (case chip-type
141+ (:sn76489 ;; And SN76496
142+ ;; If T6W28, then the volume divider is 1
143+ (when (flag? (the t/uint32 (vgm-header-sn76489-clock header)) #x80000000)
144+ (setf count 1)))
145+
146+ (:oki-m6295
147+ ;; Check for CP System 1, which needs a different volume.
148+ (when (or (string-starts-with (gd3-tag-system-name-en gd3) "CP")
149+ (string-starts-with (gd3-tag-system-name-jp gd3) "CP"))
150+ (dlog "Using CP System 1 volume hack for OKI MSM6295")
151+ (setf volume 110)))
152+
153+ (:ym2203
154+ ;; Check for YM2203's integrated AY-1-8910
155+ (when (eq paired :ay8910)
156+ (setf volume (truncate volume 2)))))
157+
158+ ;; Adjust for the number of chips
159+ (when (> count 1)
160+ (setf volume (truncate volume chip-count)))
161+
162+ ;; There may be a modification to the volume in an extra header, for check
163+ ;; for the presence of one now.
164+ (when extra-header
165+ ;; Extra header is present.
166+ ;;
167+ ;; Determine which chip we're modifying. This is needed because
168+ ;; CHIP-TYPE is always the parent chip, and PAIRED is only non_NIL if
169+ ;; we're retrieving the volume for the paired chip.
170+ ;;
171+ ;; This is just for debugging output.
172+ (let ((mod-chip (if (null paired)
173+ (string chip-type)
174+ (format nil "~a's paired ~a" chip-type paired)))
175+ (vol nil)
176+ (vol-val 0))
177+ (declare (type (or null (vector extra-header-volume)) vol)
178+ (t/uint16 vol-val)
179+ (ignorable mod-chip))
180+ (dlog "Checking for extra header volume adjustment for ~a" mod-chip)
181+
182+ ;; The value in the extra header is still looked up via the parent
183+ ;; chip.
184+ (setf vol (gethash (t/chip->int chip-type) (extra-header-volumes
185+ extra-header)))
186+
187+ ;; Might be the paired chip.
188+ (when (and (null vol) paired)
189+ (setf vol (gethash (t/chip->int paired) (extra-header-volumes extra-header))))
190+
191+ ;; Did the extra header have a volume modification?
192+ (cond
193+ (vol
194+ (setf vol-val (extra-header-volume-value (muffling (elt vol 0))))
195+
196+ ;; Bit 15 indicates whether the extra header volume value for this
197+ ;; chip is an absolute volume, or relative.
198+ ;;
199+ ;; Bit 15 = 0 means absolute.
200+ ;; Bit 15 = 1 means relative.
201+ (cond
202+ ((flag? vol-val #x8000)
203+ (dlog " Found, relative volume adjustment: ~a" (logand vol-val #x7FFF))
204+ (setf volume (coerce-to-uint16 (ash (+ (* volume (logand vol-val #x7FFF)) #x80) -8))))
205+
206+ (t
207+ (dlog " Found, absolute volume adjustment: ~a" vol-val)
208+ (setf volume vol-val)
209+
210+ ;; TODO handle option to double the SSG volume.
211+ ))
212+
213+ ;; Return early for debug message reasons.
214+ (dlog "Determined volume for ~a of ~a chip~:p: ~a" mod-chip count volume)
215+ (return-from get-chip-volume volume))
216+
217+ (t
218+ ;; There was no extra header modification found for this chip (VOL is NIL).
219+ (dlog " None found")))))
220+
221+ ;; Return the determined volume value.
222+ (dlog "Determined volume for ~a of ~a chip~:p: ~a" chip-type count volume)
223+ volume)))
224+
225+(define-typed-fn chip-change-sample-rate ((abstract-chip chip) (t/uint32 new-sample-rate))
226+ (null)
227+ "Changes the sample rate for CHIP."
228+ (declare (optimize (speed 3) (debug 1) (compilation-speed 0)))
229+
230+ (with-typed-slots ((t/uint32 cur-sample-num next-sample-num last-sample-num
231+ sample-rate player-sample-rate))
232+ chip
233+ ;; This is based on code from VGMPlay.
234+ (dlog "Sample rate change for ~a: ~a => ~a" (type-of chip) sample-rate new-sample-rate)
235+
236+ (when (= sample-rate new-sample-rate)
237+ ;; No change
238+ (return-from chip-change-sample-rate))
239+
240+ (setf sample-rate new-sample-rate)
241+
242+ ;; Adjust the resampler type by comparing the new sample rate to the playback
243+ ;; rate.
244+ (setf (chip-resampler-type chip)
245+ (cond
246+ ((< sample-rate player-sample-rate) :upsampling)
247+ ((> sample-rate player-sample-rate) :downsampling)
248+ (t :copy)))
249+
250+ (setf cur-sample-num 1)
251+ (decf next-sample-num last-sample-num)
252+ (setf last-sample-num 0))
253+ nil)
254+
255+(defmacro with-each-chip ((chip table) &body forms)
256+ (with-gensyms (key val len i)
257+ `(maphash #'(lambda (,key ,val)
258+ (declare (type (vector abstract-chip) ,val)
259+ (ignore ,key))
260+ (loop with ,len fixnum = (muffling (length ,val))
261+ for ,i fixnum from 0 below ,len
262+ for ,chip = (muffling (aref ,val ,i))
263+ do (progn ,@forms)))
264+ ,table)))
265+
266+(define-typed-fn make-chip-instance ((t/chip ct) (vgm-file vgm) (t/uint32 sample-rate) (t/uint8 sampling-mode)
267+ (t/uint32 player-sample-rate) settings)
268+ ((or null abstract-chip))
269+ (let ((chip nil)
270+ (core :unknown))
271+ (declare (type (or null abstract-chip) chip)
272+ (type keyword core))
273+
274+ (case ct
275+ (:huc6280
276+ (setf chip (make-instance 'satou-chips:huc6280))
277+ (setf core (settings-huc6280-core settings)))
278+
279+ (:c352
280+ (setf chip (make-instance 'satou-chips:c352)))
281+
282+ (:unknown (error "Attempted to start the :UNKNOWN chip"))
283+ (otherwise nil))
284+
285+ (when chip
286+ (chip-init chip vgm sample-rate sampling-mode player-sample-rate
287+ :emu-core (if (eq core :unknown)
288+ (chip-default-emu-core chip)
289+ core)
290+ :flags (chip-start-flags chip vgm)))
291+ chip))
diff -r 000000000000 -r 98c8a1775355 src/chips/chip-c352.lisp
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/chips/chip-c352.lisp Wed May 24 02:52:21 2023 -0600
@@ -0,0 +1,138 @@
1+;;;; SatouSynth
2+;;;; Copyright (C) 2023 Remilia Scarlet <remilia@posteo.jp>
3+;;;;
4+;;;; This program is free software: you can redistribute it and/or
5+;;;; modify it under the terms of the GNU Affero General Public
6+;;;; License as published by the Free Software Foundation, either
7+;;;; version 3 of the License, or (at your option) any later version.
8+;;;;
9+;;;; This program is distributed in the hope that it will be useful,
10+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
11+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12+;;;; Affero General Public License for more details.
13+;;;;
14+;;;; You should have received a copy of the GNU Affero General Public License
15+;;;; along with this program. If not, see <https://www.gnu.org/licenses/>.
16+(in-package :satou-chips)
17+
18+(defconst +chip-id/c352+ #x27)
19+
20+(deftype t/c352-core ()
21+ '(member :mame))
22+
23+(defclass c352 (abstract-chip)
24+ ((sampling-mode
25+ :initform 0
26+ :type t/uint8)
27+
28+ (chip-sample-rate
29+ :initform 0
30+ :type t/uint32)))
31+
32+(defclass c352-flags (chip-flags)
33+ ((flags
34+ :initarg :flags
35+ :initform #x01 ;; Disabling the rear outputs is the default.
36+ :type t/uint8)
37+
38+ (clock-div
39+ :initarg :clock-div
40+ :initform 1
41+ :type t/uint32)))
42+
43+(defmethod chip-init ((chip c352) (vgm vgm-file) (playback-sample-rate integer) (new-sampling-mode integer)
44+ (new-player-sample-rate integer) &key emu-core flags)
45+ (unless (typep emu-core 't/c352-core)
46+ (satou-error () "Bad emulation core for C352: ~a" emu-core))
47+
48+ (setf (slot-value chip 'satou::clock-from-header)
49+ (logand (vgm-header-c352-clock (vgm-file-header vgm)) #xBFFFFFFF))
50+ (setf (slot-value chip 'satou::player-sample-rate) playback-sample-rate)
51+
52+ (let ((chip-count (if (flag? (vgm-header-c352-clock (vgm-file-header vgm)) #x40000000) 2 1)))
53+ (%c352-init-fields chip vgm emu-core playback-sample-rate new-sampling-mode chip-count))
54+ chip)
55+
56+(defun %c352-init-fields (chip vgm emu-core playback-sample-rate new-sampling-mode chip-count)
57+ (setf (slot-value chip 'satou::volume) (satou:get-chip-volume chip vgm :c352 chip-count))
58+ (setf (slot-value chip 'satou::core) emu-core)
59+
60+ (ecase emu-core
61+ (:mame
62+ (setf (slot-value chip 'sampling-mode) new-sampling-mode)
63+ (setf (slot-value chip 'chip-sample-rate) (if (<= (slot-value chip 'satou::clock-from-header) 0)
64+ playback-sample-rate
65+ (slot-value chip 'satou::clock-from-header)))))
66+
67+ (when (>= chip-count 2)
68+ ;; Treat the second one as a paired chip.
69+ (setf (slot-value chip 'satou::paired) (make-instance 'c352))
70+ (%c352-init-fields (slot-value chip 'satou::paired) vgm emu-core playback-sample-rate new-sampling-mode
71+ (1- chip-count)))
72+ nil)
73+
74+(defmethod satou:chip-type ((chip c352))
75+ :c352)
76+
77+(defmethod satou:chip-name ((chip c352))
78+ ;; Wrap this in a RETURN-FROM so the editor doesn't think it's a doc string.
79+ (return-from chip-name "Namco C352"))
80+
81+(defmethod satou:chip-short-name ((chip c352))
82+ ;; Wrap this in a RETURN-FROM so the editor doesn't think it's a doc string.
83+ (return-from chip-short-name "C352"))
84+
85+(defmethod satou:chip-id ((chip c352))
86+ +chip-id/c352+)
87+
88+(defmethod satou:chip-default-emu-core ((chip c352))
89+ :mame)
90+
91+(defmethod satou::chip-start ((chip c352) (clock integer) &optional flags)
92+ (ecase (slot-value chip 'satou::core)
93+ (:mame
94+ (unless (typep flags 'c352-flags)
95+ (error "C352 requires start flags"))
96+
97+ (let ((emu (satou-chips/c352-mame::make-emu-c352 clock (* (slot-value flags 'clock-div) 4))))
98+ (setf (slot-value chip 'satou::emu) emu)
99+ (satou-chips/c352-mame::emu-set-options emu (slot-value flags 'flags))
100+ (satou-chips/c352-mame::emu-unmute-all emu)
101+ (setf (slot-value chip 'satou::sample-rate) (satou-chips/c352-mame::emu-start emu)))))
102+
103+ (satou::dlog "C352 Internal Sample Rate: ~a" (slot-value chip 'satou::sample-rate))
104+ (slot-value chip 'satou::sample-rate))
105+
106+(defmethod satou::chip-start-flags ((chip c352) (vgm vgm-file))
107+ (make-instance 'c352-flags :clock-div (vgm-header-c352-clock-div (vgm-file-header vgm))))
108+
109+(defmethod satou::chip-update ((chip c352) outputs (start integer) (samples integer))
110+ (declare (optimize (speed 3) (debug 1) (safety 0) (compilation-speed 0)))
111+ (satou-chips/c352-mame::emu-update (satou:chip-emu chip) outputs start samples)
112+ nil)
113+
114+(defmethod satou::chip-reset ((chip c352))
115+ (satou-chips/c352-mame::emu-reset (satou:chip-emu chip))
116+ nil)
117+
118+(defmethod satou::chip-read ((chip c352) (offset integer))
119+ (satou-chips/c352-mame::emu-read (satou:chip-emu chip) offset))
120+
121+(defmethod satou::chip-write ((chip c352) (offset integer) (data integer) &optional port)
122+ (declare (optimize (speed 3) (debug 1) (safety 0) (compilation-speed 0))
123+ (ignore port))
124+ (satou-chips/c352-mame::emu-write (satou:chip-emu chip) offset (coerce-to-uint16 data)))
125+
126+(defmethod satou::chip-write-dac ((chip c352) port command data)
127+ (sdm-log:warn! "C352 does not yet support DAC write commands"))
128+
129+(defmethod satou::chip-volume-modifier ((chip c352))
130+ (* (slot-value chip 'satou::volume) 8))
131+
132+(defmethod satou::chip-base-volume ((chip c352))
133+ #x40)
134+
135+(defmethod satou::chip-write-rom ((chip c352) (rom-size integer) (data-start integer) (data-length integer)
136+ (rom-data vector))
137+ (satou-chips/c352-mame::emu-write-rom (satou:chip-emu chip) rom-size data-start data-length rom-data)
138+ nil)
diff -r 000000000000 -r 98c8a1775355 src/chips/chip-huc6280.lisp
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/chips/chip-huc6280.lisp Wed May 24 02:52:21 2023 -0600
@@ -0,0 +1,111 @@
1+;;;; SatouSynth
2+;;;; Copyright (C) 2023 Remilia Scarlet <remilia@posteo.jp>
3+;;;;
4+;;;; This program is free software: you can redistribute it and/or
5+;;;; modify it under the terms of the GNU Affero General Public
6+;;;; License as published by the Free Software Foundation, either
7+;;;; version 3 of the License, or (at your option) any later version.
8+;;;;
9+;;;; This program is distributed in the hope that it will be useful,
10+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
11+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12+;;;; Affero General Public License for more details.
13+;;;;
14+;;;; You should have received a copy of the GNU Affero General Public License
15+;;;; along with this program. If not, see <https://www.gnu.org/licenses/>.
16+(in-package :satou-chips)
17+
18+(defconst +chip-id/huc6280+ #x1B)
19+
20+(deftype t/huc6280-core ()
21+ '(member :ootake))
22+
23+(defclass huc6280 (abstract-chip)
24+ ((sampling-mode
25+ :initform 0
26+ :type t/uint8)
27+
28+ (chip-sample-rate
29+ :initform 0
30+ :type t/uint32)))
31+
32+(defmethod chip-init ((chip huc6280) (vgm vgm-file) (playback-sample-rate integer) (new-sampling-mode integer)
33+ (new-player-sample-rate integer) &key emu-core flags)
34+ (unless (typep emu-core 't/huc6280-core)
35+ (satou-error () "Bad emulation core for HuC6280: ~a" emu-core))
36+ (when flags
37+ (sdm-log:warn! "HuC6280 does not take any init flags, ignoring"))
38+
39+ (setf (slot-value chip 'satou::clock-from-header)
40+ (logand (vgm-header-huc6280-clock (vgm-file-header vgm)) #x3FFFFFFF))
41+ (setf (slot-value chip 'satou::player-sample-rate) playback-sample-rate)
42+
43+ (let ((chip-count (if (flag? (vgm-header-huc6280-clock (vgm-file-header vgm)) #x40000000) 2 1)))
44+ (%huc6280-init-fields chip vgm emu-core playback-sample-rate new-sampling-mode chip-count))
45+ chip)
46+
47+(defun %huc6280-init-fields (chip vgm emu-core playback-sample-rate new-sampling-mode chip-count)
48+ (setf (slot-value chip 'satou::volume) (satou:get-chip-volume chip vgm :huc6280 chip-count))
49+ (setf (slot-value chip 'satou::core) emu-core)
50+
51+ (ecase emu-core
52+ (:ootake
53+ (setf (slot-value chip 'sampling-mode) new-sampling-mode)
54+ (setf (slot-value chip 'chip-sample-rate) (if (<= (slot-value chip 'satou::clock-from-header) 0)
55+ playback-sample-rate
56+ (slot-value chip 'satou::clock-from-header)))))
57+
58+ (when (>= chip-count 2)
59+ ;; Treat the second one as a paired chip.
60+ (setf (slot-value chip 'satou::paired) (make-instance 'huc6280))
61+ (%huc6280-init-fields (slot-value chip 'satou::paired) vgm emu-core playback-sample-rate new-sampling-mode
62+ (1- chip-count)))
63+ nil)
64+
65+(defmethod satou:chip-type ((chip huc6280))
66+ :huc6280)
67+
68+(defmethod satou:chip-name ((chip huc6280))
69+ ;; Wrap this in a RETURN-FROM so the editor doesn't think it's a doc string.
70+ (return-from chip-name "Hudson HuC6280"))
71+
72+(defmethod satou:chip-short-name ((chip huc6280))
73+ ;; Wrap this in a RETURN-FROM so the editor doesn't think it's a doc string.
74+ (return-from chip-short-name "HuC6280"))
75+
76+(defmethod satou:chip-id ((chip huc6280))
77+ +chip-id/huc6280+)
78+
79+(defmethod satou:chip-default-emu-core ((chip huc6280))
80+ :ootake)
81+
82+(defmethod satou::chip-start ((chip huc6280) (clock integer) &optional flags)
83+ (when flags
84+ (sdm-log:warn! "HuC6280 does not take any init flags, ignoring"))
85+
86+ (ecase (slot-value chip 'satou::core)
87+ (:ootake
88+ (setf (slot-value chip 'satou::sample-rate) (slot-value chip 'satou::player-sample-rate))
89+ (setf (slot-value chip 'satou::emu)
90+ (satou-chips/huc6280-ootake::make-emu-ootake clock (slot-value chip 'satou::sample-rate)))))
91+ (slot-value chip 'satou::sample-rate))
92+
93+(defmethod satou::chip-update ((chip huc6280) outputs (start integer) (samples integer))
94+ (declare (optimize (speed 3) (debug 1) (safety 0) (compilation-speed 0)))
95+ (satou-chips/huc6280-ootake::ootake-update (satou:chip-emu chip) outputs start samples)
96+ nil)
97+
98+(defmethod satou::chip-reset ((chip huc6280))
99+ (satou-chips/huc6280-ootake::ootake-reset (satou:chip-emu chip))
100+ nil)
101+
102+(defmethod satou::chip-read ((chip huc6280) (offset integer))
103+ (satou-chips/huc6280-ootake::ootake-read (satou:chip-emu chip) offset))
104+
105+(defmethod satou::chip-write ((chip huc6280) (offset integer) (data integer) &optional port)
106+ (declare (optimize (speed 3) (debug 1) (safety 0) (compilation-speed 0))
107+ (ignore port))
108+ (satou-chips/huc6280-ootake::ootake-write (satou:chip-emu chip) offset data))
109+
110+(defmethod satou::chip-base-volume ((chip huc6280))
111+ 256)
diff -r 000000000000 -r 98c8a1775355 src/chips/common.lisp
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/chips/common.lisp Wed May 24 02:52:21 2023 -0600
@@ -0,0 +1,28 @@
1+;;;; SatouSynth
2+;;;; Copyright (C) 2023 Remilia Scarlet <remilia@posteo.jp>
3+;;;;
4+;;;; This program is free software: you can redistribute it and/or
5+;;;; modify it under the terms of the GNU Affero General Public
6+;;;; License as published by the Free Software Foundation, either
7+;;;; version 3 of the License, or (at your option) any later version.
8+;;;;
9+;;;; This program is distributed in the hope that it will be useful,
10+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
11+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12+;;;; Affero General Public License for more details.
13+;;;;
14+;;;; You should have received a copy of the GNU Affero General Public License
15+;;;; along with this program. If not, see <https://www.gnu.org/licenses/>.
16+(in-package :satou-chips)
17+
18+(defmacro with-output-buffers ((left right output-buffers samples emu-name) &body forms)
19+ `(let ((,left (svref ,output-buffers 0))
20+ (,right (svref ,output-buffers 1)))
21+ (declare (type t/int32-vector ,left ,right))
22+
23+ (when (or (< (length ,left) ,samples)
24+ (< (length ,right) ,samples))
25+ (error "~a: Bad number of samples (expected ~a, but buffers have ~a and ~a)"
26+ ,emu-name ,samples (length ,left) (length ,right)))
27+
28+ ,@forms))
diff -r 000000000000 -r 98c8a1775355 src/chips/emu-c352-mame.lisp
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/chips/emu-c352-mame.lisp Wed May 24 02:52:21 2023 -0600
@@ -0,0 +1,355 @@
1+(in-package :satou-chips)
2+
3+(defpackage :satou-chips/c352-mame
4+ (:use :common-lisp :cl-sdm :satou :satou-chips)
5+ (:nicknames :c352-mame)
6+ (:shadowing-import-from :common-lisp #:write-string))
7+
8+(in-package :satou-chips/c352-mame)
9+
10+(defining-consts
11+ (+flag-busy+ #x8000) ;; Channel is busy
12+ (+flag-key-on+ #x4000) ;; Key on
13+ (+flag-key-off+ #x2000) ;; Key off
14+ (+flag-loop-trig+ #x1000) ;; Loop trigger
15+ (+flag-loop-hist+ #x0800) ;; Loop history
16+ (+flag-fm+ #x0400) ;; Frequency modulation
17+ (+flag-phase-rl+ #x0200) ;; Rear/Left invert phase 180 degrees
18+ (+flag-phase-fl+ #x0100) ;; Front/Left invert phase 180 degrees
19+ (+flag-phase-fr+ #x0080) ;; Invert phase 180 degrees (flip sign of samples)
20+ (+flag-ldir+ #x0040) ;; Loop direction
21+ (+flag-link+ #x0020) ;; "long-format" sample (can't loop)
22+ (+flag-noise+ #x0010) ;; Play noise instead of the sample
23+ (+flag-mulaw+ #x0008) ;; Sample is µLaw encoded
24+ (+flag-no-filter+ #x0004) ;; Don't apply filter
25+ (+flag-revloop+ #x0003) ;; Loop backward
26+ (+flag-loop+ #x0002) ;; Loop forward
27+ (+flag-reverse+ #x0001) ;; Play the sample backwards
28+
29+ (+num-voices+ 32))
30+
31+(defstruct (voice (:conc-name %voice-))
32+ (pos 0 :type t/uint32)
33+ (counter 0 :type t/uint32)
34+ (sample 0 :type t/int16)
35+ (last-sample 0 :type t/int16)
36+ (vol-f 0 :type t/uint16)
37+ (vol-r 0 :type t/uint16)
38+ (cur-volume (new-array 4 t/uint8) :type (simple-array t/uint8 (4)))
39+ (freq 0 :type t/uint16)
40+ (flags 0 :type t/uint16)
41+ (wave-bank 0 :type t/uint16)
42+ (wave-start 0 :type t/uint16)
43+ (wave-end 0 :type t/uint16)
44+ (wave-loop 0 :type t/uint16)
45+ (mute 0 :type t/uint8))
46+
47+(define-typed-fn %ramp-volume ((voice voice) (fixnum channel) (t/uint8 val))
48+ (null t)
49+ (declare (optimize (speed 3) (debug 0) (safety 0) (compilation-speed 0)))
50+ (let ((vol-delta (- (aref (%voice-cur-volume voice) channel) val)))
51+ (unless (zerop vol-delta)
52+ (incf (aref (%voice-cur-volume voice) channel)
53+ (if (plusp vol-delta) -1 1))))
54+ nil)
55+
56+(defstruct (emu-c352 (:conc-name %emu-)
57+ (:constructor %make-emu-c352))
58+ (sample-rate-base 0 :type t/uint32)
59+ (divider 0 :type t/uint16)
60+ (voices nil :type (or null (simple-array voice)))
61+ (random 0 :type t/uint16)
62+ (control 0 :type t/uint16)
63+ (wave (new-array 0 t/uint8) :type t/uint8-array)
64+ (wave-mask 0 :type t/uint32)
65+ (mute-rear 0 :type t/uint8) ;; This is derived from a flag in the VGM header
66+ (mulaw-table (new-array 256 t/int16) :type (simple-array t/int16 (256)))
67+ (mute-all-rear 0 :type t/uint8)
68+ (temp-buf (new-array 4 t/int32) :type (simple-array t/int32 (4))))
69+
70+(defmethod print-object ((obj emu-c352) out)
71+ (print-unreadable-object (obj out :type t)
72+ (format out "Sample rate: ~a" (%emu-sample-rate-base obj))))
73+
74+(defmacro make-voice-array ()
75+ `(make-array +num-voices+ :element-type 'voice
76+ :initial-contents (loop repeat +num-voices+
77+ collect (make-voice))))
78+
79+(define-typed-fn make-emu-c352 ((t/uint32 clock clock-div))
80+ (emu-c352)
81+ (let* ((divider (if (/= clock-div 0)
82+ (coerce-to-uint16 clock-div)
83+ 288))
84+ (ret (%make-emu-c352 :divider divider
85+ :sample-rate-base (truncate (logand clock #x7FFFFFFF) divider)
86+ :mute-rear (ash (logand clock #x80000000) -31)
87+ :voices (make-voice-array)))
88+ (j 0))
89+ (declare (type t/uint16 j))
90+ (dotimes (i 128)
91+ (setf (aref (%emu-mulaw-table ret) i)
92+ (coerce-to-int16 (ash j 5)))
93+ (cond
94+ ((< i 16) (incf j))
95+ ((< i 24) (incf j 2))
96+ ((< i 48) (incf j 4))
97+ ((< i 100) (incf j 8))
98+ (t (incf j 16)))
99+ (setf j (coerce-to-uint16 j)))
100+
101+ (loop for i fixnum from 128 below 256 do
102+ (setf (aref (%emu-mulaw-table ret) i)
103+ (coerce-to-int16 (logand (lognot (aref (%emu-mulaw-table ret) (- i 128))) #xFFE0))))
104+ ret))
105+
106+(define-typed-fn %fetch-sample ((emu-c352 emu) (voice voice))
107+ (null t)
108+ (declare (optimize (speed 3) (debug 0) (safety 0) (compilation-speed 0)))
109+
110+ (setf (%voice-last-sample voice) (%voice-sample voice))
111+
112+ (cond
113+ ((flag? (%voice-flags voice) +flag-noise+)
114+ (setf (%emu-random emu) (coerce-to-uint16
115+ (logxor (ash (%emu-random emu) -1)
116+ (logand (logand (- (coerce-to-int16 (%emu-random emu))) 1) #xFFF6))))
117+ (setf (%voice-sample voice) (coerce-to-int16 (%emu-random emu))))
118+
119+ (t
120+ (let ((smp (aref (%emu-wave emu) (logand (%voice-pos voice) (%emu-wave-mask emu))))
121+ (pos 0))
122+ (declare (type t/uint32 pos)
123+ (type t/uint8 smp))
124+
125+ (setf (%voice-sample voice) (coerce-to-int16 (ash smp 8)))
126+ (when (flag? (%voice-flags voice) +flag-mulaw+)
127+ (setf (%voice-sample voice) (aref (%emu-mulaw-table emu) smp)))
128+
129+ (setf pos (logand (%voice-pos voice) #xFFFF))
130+
131+ (cond
132+ ((and (flag? (%voice-flags voice) +flag-loop+) (flag? (%voice-flags voice) +flag-reverse+))
133+ ;; Backwards -> Forwards
134+ (cond
135+ ((and (flag? (%voice-flags voice) +flag-ldir+)
136+ (= pos (%voice-wave-loop voice)))
137+ (logandf (%voice-flags voice) (lognot +flag-ldir+)))
138+ ((and (not (flag? (%voice-flags voice) +flag-ldir+))
139+ (= pos (%voice-wave-end voice)))
140+ (logiorf (%voice-flags voice) +flag-ldir+)))
141+
142+ (incf (%voice-pos voice) (if (flag? (%voice-flags voice) +flag-ldir+) -1 1)))
143+
144+ ((= pos (%voice-wave-end voice))
145+ (cond
146+ ((and (flag? (%voice-flags voice) +flag-link+)
147+ (flag? (%voice-flags voice) +flag-loop+))
148+ (setf (%voice-pos voice) (coerce-to-uint16 (logior (ash (%voice-wave-start voice) 16)
149+ (%voice-wave-loop voice))))
150+ (logiorf (%voice-flags voice) +flag-loop-hist+))
151+
152+ ((flag? (%voice-flags voice) +flag-loop+)
153+ (setf (%voice-pos voice) (logior (logand (%voice-pos voice) #xFF0000)
154+ (%voice-wave-loop voice)))
155+ (logiorf (%voice-flags voice) +flag-loop-hist+))
156+
157+ (t
158+ (logiorf (%voice-flags voice) +flag-key-off+)
159+ (logandf (%voice-flags voice) (lognot +flag-busy+))
160+ (setf (%voice-sample voice) 0))))
161+
162+ (t
163+ (incf (%voice-pos voice) (if (flag? (%voice-flags voice) +flag-reverse+) -1 1)))))))
164+ nil)
165+
166+(define-typed-fn emu-update ((emu-c352 emu) (satou::t/output-buffer outputs) (t/uint32 start samples))
167+ (null)
168+ (declare (optimize (speed 3) (debug 1) (compilation-speed 0)))
169+ (with-output-buffers (out-l out-r outputs samples "C352")
170+ (let ((smp 0)
171+ (next-counter 0)
172+ (out-buf (%emu-temp-buf emu)))
173+ (declare (type t/int16 smp)
174+ (type t/uint32 next-counter))
175+
176+ ;; Clear output buffers
177+ (fill out-l 0 :start start :end (+ start samples))
178+ (fill out-r 0 :start start :end (+ start samples))
179+
180+ ;; Render
181+ (loop for i fixnum from start below (+ samples start) do
182+ ;; Clear temporary buffer
183+ (fill out-buf 0)
184+
185+ ;; Render each voice
186+ (loop for voice across (%emu-voices emu)
187+ for vflags = (%voice-flags voice)
188+ do (setf smp 0)
189+
190+ ;; Only look at voices that are doing something
191+ (when (flag? vflags +flag-busy+)
192+ (setf next-counter (+ (%voice-counter voice) (%voice-freq voice)))
193+ (when (flag? next-counter #x10000)
194+ (%fetch-sample emu voice)
195+ (setf vflags (%voice-flags voice)))
196+
197+ (when (flag? (logxor next-counter (%voice-counter voice)) #x18000)
198+ (%ramp-volume voice 0 (ash (%voice-vol-f voice) -8))
199+ (%ramp-volume voice 1 (logand (%voice-vol-f voice) #xFF))
200+ (%ramp-volume voice 2 (ash (%voice-vol-r voice) -8))
201+ (%ramp-volume voice 3 (logand (%voice-vol-r voice) #xFF)))
202+
203+ (setf (%voice-counter voice) (logand next-counter #xFFFF))
204+ (setf smp (%voice-sample voice))
205+
206+ ;; Interpolate samples
207+ (unless (flag? vflags +flag-no-filter+)
208+ (setf smp (coerce-to-int16
209+ (+ (%voice-last-sample voice)
210+ (ash (* (%voice-counter voice)
211+ (- (%voice-sample voice) (%voice-last-sample voice)))
212+ -16))))))
213+
214+ ;; Mix into temporary output buffer if the voice isn't muted
215+ ;; Left first
216+ (incf (aref out-buf 0)
217+ (coerce-to-int16 (ash (* (if (flag? vflags +flag-phase-fl+) (- smp) smp)
218+ (aref (%voice-cur-volume voice) 0))
219+ -8)))
220+ (incf (aref out-buf 2)
221+ (coerce-to-int16 (ash (* (if (flag? vflags +flag-phase-rl+) (- smp) smp)
222+ (aref (%voice-cur-volume voice) 2))
223+ -8)))
224+
225+ ;; Now the right
226+ (incf (aref out-buf 1)
227+ (coerce-to-int16 (ash (* (if (flag? vflags +flag-phase-fr+) (- smp) smp)
228+ (aref (%voice-cur-volume voice) 1))
229+ -8)))
230+ (incf (aref out-buf 3)
231+ (coerce-to-int16 (ash (* (if (flag? vflags +flag-phase-fr+) (- smp) smp)
232+ (aref (%voice-cur-volume voice) 3))
233+ -8))))
234+
235+ (satou::muffling
236+ ;; Mix into output buffers
237+ (incf (aref out-l i) (aref out-buf 0))
238+ (incf (aref out-r i) (aref out-buf 1))
239+
240+ ;; Also mix the quadraphonic sound in as stereo
241+ (when (and (zerop (%emu-mute-rear emu))
242+ (zerop (%emu-mute-all-rear emu)))
243+ (incf (aref out-l i) (aref out-buf 2))
244+ (incf (aref out-r i) (aref out-buf 3)))))))
245+ nil)
246+
247+(define-typed-fn emu-start ((emu-c352 emu))
248+ (t/uint32)
249+ (declare (optimize (speed 3) (debug 1) (safety 0) (compilation-speed 0)))
250+ (%emu-sample-rate-base emu))
251+
252+(define-typed-fn emu-reset ((emu-c352 emu))
253+ (null)
254+ (declare (optimize (speed 3) (debug 1) (safety 0) (compilation-speed 0)))
255+ ;; Clear channel states
256+ (setf (%emu-voices emu) (make-voice-array))
257+
258+ ;; Init noise generator
259+ (setf (%emu-random emu) #x1234)
260+ (setf (%emu-control emu) 0)
261+ nil)
262+
263+(define-typed-fn emu-read ((emu-c352 emu) (fixnum address))
264+ (t/uint16 t)
265+ (declare (optimize (speed 3) (debug 1) (safety 0) (compilation-speed 0)))
266+ (cond
267+ ((< address #x100) ;; Channel registers
268+ (let ((voice (aref (%emu-voices emu) (truncate address 8))))
269+ (case (mod address 8)
270+ (0 (%voice-vol-f voice))
271+ (1 (%voice-vol-r voice))
272+ (2 (%voice-freq voice))
273+ (3 (%voice-flags voice))
274+ (4 (%voice-wave-bank voice))
275+ (5 (%voice-wave-start voice))
276+ (6 (%voice-wave-end voice))
277+ (7 (%voice-wave-loop voice))
278+ (otherwise 0))))
279+
280+ ((= address #x200)
281+ (%emu-control emu))
282+
283+ (t 0)))
284+
285+(define-typed-fn emu-write ((emu-c352 emu) (fixnum address) (t/uint16 val))
286+ (null t)
287+ (declare (optimize (speed 3) (debug 1) (safety 0) (compilation-speed 0)))
288+ (cond
289+ ((< address #x100) ;; Channel registers
290+ (let ((voice (aref (%emu-voices emu) (truncate address 8))))
291+ (case (mod address 8)
292+ (0 (setf (%voice-vol-f voice) val))
293+ (1 (setf (%voice-vol-r voice) val))
294+ (2 (setf (%voice-freq voice) val))
295+ (3 (setf (%voice-flags voice) val))
296+ (4 (setf (%voice-wave-bank voice) val))
297+ (5 (setf (%voice-wave-start voice) val))
298+ (6 (setf (%voice-wave-end voice) val))
299+ (7 (setf (%voice-wave-loop voice) val)))))
300+
301+ ((= address #x200)
302+ (setf (%emu-control emu) val))
303+
304+ ((= address #x202) ;; Key on/off
305+ (loop for voice across (%emu-voices emu) do
306+ (cond
307+ ((flag? (%voice-flags voice) +flag-key-on+)
308+ (setf (%voice-pos voice) (logior (ash (%voice-wave-bank voice) 16) (%voice-wave-start voice)))
309+ (setf (%voice-sample voice) 0)
310+ (setf (%voice-last-sample voice) 0)
311+ (setf (%voice-counter voice) #xFFFF)
312+ (logiorf (%voice-flags voice) +flag-busy+)
313+ (logandf (%voice-flags voice) (lognot (logior +flag-key-on+ +flag-loop-hist+)))
314+ (setf (aref (%voice-cur-volume voice) 0) 0)
315+ (setf (aref (%voice-cur-volume voice) 1) 0)
316+ (setf (aref (%voice-cur-volume voice) 2) 0)
317+ (setf (aref (%voice-cur-volume voice) 3) 0))
318+
319+ ((flag? (%voice-flags voice) +flag-key-off+)
320+ (logandf (%voice-flags voice) (lognot (logior +flag-busy+ +flag-key-off+)))
321+ (setf (%voice-counter voice) #xFFFF))))))
322+ nil)
323+
324+(define-typed-fn emu-set-options ((emu-c352 emu) (t/uint8 flags))
325+ (null)
326+ (declare (optimize (speed 3) (debug 1) (safety 0) (compilation-speed 0)))
327+ (setf (%emu-mute-all-rear emu) (logand flags 1))
328+ nil)
329+
330+(define-typed-fn emu-unmute-all ((emu-c352 emu))
331+ (null)
332+ (declare (optimize (speed 3) (debug 1) (safety 0) (compilation-speed 0)))
333+ (loop for voice across (%emu-voices emu) do
334+ (setf (%voice-mute voice) 0))
335+ nil)
336+
337+(define-typed-fn emu-write-rom ((emu-c352 emu) (t/int32 rom-size data-start data-length) (t/uint8-array rom-data))
338+ (null)
339+ (declare (optimize (speed 3) (debug 1) (safety 0) (compilation-speed 0)))
340+ (when (/= (length (%emu-wave emu)) rom-size)
341+ (setf (%emu-wave emu) (new-array rom-size t/uint8 #xFF))
342+ (setf (%emu-wave-mask emu) 1)
343+ (loop while (< (%emu-wave-mask emu) (length (%emu-wave emu))) do
344+ (setf (%emu-wave-mask emu) (ash (%emu-wave-mask emu) 1)))
345+ (decf (%emu-wave-mask emu)))
346+
347+ (unless (> data-start rom-size)
348+ (let ((data-len (if (> (+ data-start data-length) rom-size)
349+ (- rom-size data-start)
350+ data-length)))
351+ ;; Copy the memory
352+ (dotimes (i data-len)
353+ (setf (aref (%emu-wave emu) (+ i data-start))
354+ (aref rom-data i)))))
355+ nil)
diff -r 000000000000 -r 98c8a1775355 src/chips/emu-huc6280-ootake.lisp
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/chips/emu-huc6280-ootake.lisp Wed May 24 02:52:21 2023 -0600
@@ -0,0 +1,694 @@
1+;;;; Ootake PSG
2+;;;; ＰＳＧを記述するのに必要な定義および関数のプロトタイプ宣言を行ないます．
3+;;;; Copyright (C) 2004 Ki
4+;;;; Copyright(C) 2006-2012 Kitao Nakamura
5+;;;; Copyright (C) 2023 Remilia Scarlet
6+;;;;
7+;;;; This program is free software; you can redistribute it and/or modify it
8+;;;; under the terms of the GNU General Public License as published by the Free
9+;;;; Software Foundation; either version 2 of the License, or (at your option)
10+;;;; any later version.
11+;;;;
12+;;;; This program is distributed in the hope that it will be useful, but WITHOUT
13+;;;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
14+;;;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for
15+;;;; more details.
16+;;;;
17+;;;; You should have received a copy of the GNU General Public License along
18+;;;; with this program; if not, write to the Free Software Foundation, Inc., 59
19+;;;; Temple Place, Suite 330, Boston, MA 02111-1307 USA
20+;;;;
21+;;;; ・キューの参照処理をシンプルにした。テンポの安定性および音質の向上。
22+;;;; ・オーバーサンプリングしないようにした。（筆者の主観もあるが、PSGの場合、響きの
23+;;;; 美しさが損なわれてしまうケースが多いため。速度的にもアップ）
24+;;;; ・ノイズの音質・音量を実機並みに調整した。v0.72
25+;;;; ・ノイズの周波数に0x1Fが書き込まれたときは、0x1Eと同じ周波数で音量を半分にして
26+;;;; 鳴らすようにした。v0.68
27+;;;; ・現状は再生サンプルレートは44.1KHz固定とした。(CD-DA再生時の速度アップのため)
28+;;;; ・DDA音の発声が終了したときにいきなり波形を0にせず、フェードアウトさせるように
29+;;;; し、ノイズを軽減した。v0.57
30+;;;; ・DDAモード(サンプリング発声)のときの波形データのノイズが多く含まれている部分
31+;;;; をカットしして、音質を上げた。音量も調節した。v0.59
32+;;;; ・ノイズ音の音質・音量を調整して、実機の雰囲気に近づけた。v0.68
33+;;;; ・waveIndexの初期化とDDAモード時の動作を見直して実機の動作に近づけた。v0.63
34+;;;; ・waveIndexの初期化時にwaveテーブルも初期化するようにした。ファイヤープロレス
35+;;;; リング、Ｆ１トリプルバトルなどの音が実機に近づいた。v0.65
36+;;;; ・waveの波形の正負を実機同様にした。v0.74
37+;;;; ・waveの最小値が-14になるようにし音質を整えた。v0.74
38+;;;; ・クリティカルセクションは必要ない(書き込みが同時に行われるわけではない)ような
39+;;;; ので、省略し高速化した。v1.09
40+;;;; ・キュー処理(ApuQueue.c)をここに統合して高速化した。v1.10
41+;;;; ・低音領域のボリュームを上げて実機並みの聞こえやすさに近づけた。v1.46
42+;;;; ・LFO処理のの実装。"はにいいんざすかい"のOPや、フラッシュハイダースの効果音が
43+;;;; 実機の音に近づいた。v1.59
44+(in-package :satou-chips)
45+
46+;;;;
47+;;;; Actual implementation of the HuC6280 emulator based on Ootake's implementation
48+;;;;
49+;;;; Remi: I've purposely left the comments in Japanese.
50+;;;;
51+
52+(defpackage :satou-chips/huc6280-ootake
53+ (:use :common-lisp :cl-sdm :satou :satou-chips)
54+ (:nicknames :huc6280-ootake)
55+ (:shadowing-import-from :common-lisp #:write-string))
56+
57+(in-package :satou-chips/huc6280-ootake)
58+
59+(defining-consts
60+ (+n-channel+ 6)
61+
62+ ;; Kitao更新。PSGはオーバーサンプリングすると響きの美しさが損なわれてしまうの
63+ ;; でオーバーサンプリングしないようにした。速度的にもアップ。
64+ (+oversample-rate+ 1.0d0)
65+
66+ ;; 21.8500。Kitao追加。PSG音量の減少値。*6.0は各チャンネル足したぶんを割る意味。
67+ ;; 大きいほど音は減る。CDDAが100%のときにちょうど良いぐらいの音量に合わせよう。
68+ ;; v2.19,v2.37,v2.39,v2.62更新
69+ (+psg-decline+ (* 21.8500d0 6.0d0))
70+
71+ ;; -1.05809999010で雀探物語２OK。Kitao追加。音量テーブルの減少値。マイナス
72+ ;; -が大きいほど小さい音が聞こえづらくなる。マイナスが小さすぎると平面的な
73+ ;; -音になる。v2.19,v2.37,v2.39,v2.40,v2.62,v2.65更新
74+ (+vol-table-decline+ -1.05809999010d0)
75+
76+ ;; 0.30599899951。Kitao追加。サンプリング音の消音時の音の減退量。ソルジャーブ
77+ ;; レイド,将棋初心者無用の音声で調整。基本的にこの値が小さいほうがノイズが減る
78+ ;; (逆のケースもある)。v2.40
79+ (+sample-fade-decline+ 0.305998999951d0))
80+
81+;;;; [DEV NOTE]
82+;;;;
83+;;;; MAL --- 0 - 15 (15 で -0[dB], １減るごとに -3.0 [dB])
84+;;;; AL --- 0 - 31 (31 で -0[dB], １減るごとに -1.5 [dB])
85+;;;; LAL/RAL --- 0 - 15 (15 で -0[dB], １減るごとに -3.0 [dB])
86+;;;;
87+;;;; 次のように解釈しなおす。
88+;;;;
89+;;;; MAL*2 --- 0 - 30 (30 で -0[dB], １減るごとに -1.5 [dB])
90+;;;; AL --- 0 - 31 (31 で -0[dB], １減るごとに -1.5 [dB])
91+;;;; LAL/RAL*2 --- 0 - 30 (30 で -0[dB], １減るごとに -1.5 [dB])
92+;;;;
93+;;;;
94+;;;; dB = 20 * log10(OUT/IN)
95+;;;;
96+;;;; dB / 20 = log10(OUT/IN)
97+;;;;
98+;;;; OUT/IN = 10^(dB/20)
99+;;;;
100+;;;; IN(最大出力) を 1.0 とすると、
101+;;;;
102+;;;; OUT = 10^(dB/20)
103+;;;;
104+;;;; -91 <= -(MAL*2 + AL + LAL(RAL)*2) <= 0
105+;;;;
106+;;;; だから、最も小さい音は、
107+;;;;
108+;;;; -91 * 1.5 [dB] = -136.5 [dB] = 10^(-136.5/20) ~= 1.496236e-7 [倍]
109+;;;;
110+;;;; となる。
111+;;;;
112+;;;; 1e-7 オーダーの値は、固定小数点で表現しようとすると、小数部だけで
113+;;;; 24 ビット以上必要で、なおかつ１６ビットの音声を扱うためには +16ビット
114+;;;; だから 24+16 = 40ビット以上必要になる。よって、32 ビットの処理系で
115+;;;; ＰＣＥの音声を固定小数点で表現するのはつらい。そこで、波形の計算は
116+;;;; float で行なうことにする。
117+;;;;
118+;;;; float から出力形式に変換するのはＡＰＵの仕事とする。
119+;;;;
120+;;;; [2004.4.28] やっぱり Sint32 で実装することにした(微小な値は無視する)。
121+;;;;
122+;;;; ＣＰＵとＰＳＧは同じＩＣにパッケージしてあるのだが、
123+;;;; 実際にはＰＳＧはＣＰＵの１／２のクロックで動作すると考えて良いようだ。
124+;;;; よって、ＰＳＧの動作周波数 Fpsg は、
125+;;;;
126+;;;; Fpsg = 21.47727 [MHz] / 3 / 2 = 3.579545 [MHz]
127+;;;;
128+;;;; となる。
129+;;;;
130+;;;; たとえば３２サンプルを１周期とする波形が再生されるとき、
131+;;;; この周波数の周期でサンプルを１つずつ拾い出すと、
132+;;;;
133+;;;; M = 3579545 / 32 = 111860.78125 [Hz]
134+;;;;
135+;;;; というマジックナンバーが得られる（ファミコンと同じ）。
136+;;;; ただし、再生周波数が固定では曲の演奏ができないので、
137+;;;; FRQ なる周波数パラメータを用いて再生周波数を変化させる。
138+;;;; FRQ はＰＳＧのレジスタに書き込まれる１２ビット長のパラメータで、
139+;;;; ↑で得られたマジックナンバーの「割る数」になっている。
140+;;;;
141+;;;; 上の３２サンプルを１周期とする波形が再生されるとき、
142+;;;; この波形の周波数 F は、FRQ を用いて、
143+;;;;
144+;;;; F = M / FRQ [Hz] (FRQ != 0)
145+;;;;
146+;;;; となる。
147+;;;;
148+;;;; ＰＣの再生サンプリング周波数が Fpc [Hz] だとすると、
149+;;;; １周期３２サンプルの波形の再生周波数 F2 は F2 = Fpc / 32 [Hz]。
150+;;;; よって、ＰＣの１サンプルに対して、ＰＣＥの１サンプルを拾い出す
151+;;;; カウンタの進み幅 I は
152+;;;;
153+;;;; I = F / F2 = 32 * F / Fpc = Fpsg / FRQ / Fpc [単位なし]
154+;;;;
155+;;;; となる。
156+;;;;
157+;;;; [NOISE CHANNEL]
158+;;;;
159+;;;; 擬似ノイズの生成にはＭ系列(maximum length sequence)が用いられる。
160+;;;; Ｍ系列のビット長は未調査につき不明。
161+;;;; ここでは仮に１５ビットとして実装を行なう。
162+;;;; 出力は１ビットで、D0 がゼロのときは負の値、１のときは正の値とする。
163+;;;;
164+;;;; ＰＣの１サンプルに対して、ＰＣＥの１サンプルを拾い出す
165+;;;; カウンタの進み幅 I は、
166+;;;;
167+;;;; I = Fpsg / 64 / FRQ / Fpc (FRQ != 0)
168+;;;;
169+;;;; となる。
170+;;;;
171+;;;; [再生クオリティ向上について] 2004.6.22
172+;;;;
173+;;;; エミュレータでは、ＰＳＧのレジスタにデータが書き込まれるまで、
174+;;;; 次に発声すべき音がわからない。レジスタにデータが書き込まれたときに、
175+;;;; サウンドバッファを更新したいのだけど、あいにく現在の実装では、
176+;;;; サウンドバッファの更新は別スレッドで行なわれていて、
177+;;;; エミュレーションスレッドから任意の時間に更新することができない。
178+;;;;
179+;;;; これまでの再生では、サウンドバッファの更新時のレジスタ設定のみが
180+;;;; 有効だったが、これだと例えばサウンドバッファ更新の合間に一瞬だけ
181+;;;; 出力された音などが無視されてしまう。これは特にＤＤＡモードやノイズが
182+;;;; リズムパートとして使用される上で問題になる。
183+;;;;
184+;;;; レジスタに書き込まれた値をきちんと音声出力に反映させるには、
185+;;;; 過去に書き込まれたレジスタの値(いつ、どのレジスタに、何が書き込まれたか)
186+;;;; を保存しておいて、サウンドバッファ更新時にこれを参照する方法が
187+;;;; 考えられる。どのくらい過去までレジスタの値を保存しておくかは、
188+;;;; サウンドバッファの長さにもよると思われるが、とりあえずは試行錯誤で
189+;;;; 決めることにする。
190+;;;;
191+;;;; ＰＳＧレジスタへの書き込み動作はエミュレーションスレッドで
192+;;;; 行なわれ、サウンドバッファ更新はその専用スレッドで行なわれる。
193+;;;; これだと、エミュレーションスレッドがレジスタのキューに書き込みを
194+;;;; 行なっている最中に、サウンドバッファ更新スレッドがキューから
195+;;;; 読み出しを行なってしまい、アクセスが衝突する。この問題を解決するには、
196+;;;;
197+;;;; １．サウンドバッファの更新を別スレッドで行なわない
198+;;;; ２．キューのアクセス部分を排他処理にする
199+;;;;
200+;;;; の２とおりが考えられる。とりあえず２の方法をとることにする。
201+
202+(defstruct (psg (:conc-name %psg-))
203+ (freq 0 :type t/uint32)
204+ (on-p nil :type boolean)
205+ (dda-p nil :type boolean)
206+ (volume 0 :type t/uint32)
207+ (volume-l 0 :type t/uint32)
208+ (volume-r 0 :type t/uint32)
209+ (out-volume-l 0 :type t/int32)
210+ (out-volume-r 0 :type t/int32)
211+ (wave (new-array 32 t/int32) :type (simple-array t/int32 (32)))
212+ (wave-index 0 :type t/uint32)
213+ (dda-sample 0 :type t/int32)
214+ (phase 0 :type t/uint32)
215+ (delta-phase 0 :type t/uint32)
216+ (noise-on-p nil :type boolean)
217+ (noise-freq 0 :type t/uint32)
218+ (delta-noise-phase 0 :type t/uint32))
219+
220+(defmethod print-object ((obj psg) out)
221+ (print-unreadable-object (obj out :type t)
222+ (format out "On: ~:[no~;yes~]" (%psg-on-p obj))))
223+
224+(defstruct (emu-ootake (:constructor %make-emu-ootake)
225+ (:conc-name %ootake-))
226+ (sample-rate 0.0d0 :type double-float)
227+ (psg-freq 0.0d0 :type double-float)
228+ (resample-rate 0.0d0 :type double-float)
229+
230+ (psg nil :type (or null (simple-array psg (8))))
231+ (dda-fade-out-l (new-array 8 t/int32) :type (simple-array t/int32 (8)))
232+ (dda-fade-out-r (new-array 8 t/int32) :type (simple-array t/int32 (8)))
233+ (channel 0 :type t/uint32) ;; 0 - 5
234+ (main-volume-l 0 :type t/uint32) ;; 0 - 15
235+ (main-volume-r 0 :type t/uint32) ;; 0 - 15
236+ (lfo-freq 0 :type t/uint32)
237+ (lfo-on-p nil :type boolean)
238+ (lfo-ctrl 0 :type t/uint32)
239+ (lfo-shift 0 :type t/uint32)
240+ (psg-volume-effect 0 :type t/int32)
241+ (volume 0.0d0 :type double-float)
242+ (vol 0.0d0 :type double-float)
243+ (psg-mute (new-array 8 boolean nil) :type (simple-array boolean (8)))
244+ (port (new-array 16 t/uint8) :type (simple-array t/uint8 (16)))
245+ (wave-crash-p nil :type boolean)
246+ (honey-in-the-sky-p nil :type boolean)
247+ (volume-table (new-array 92 t/int32) :type (simple-array t/int32 (92)))
248+ (noise-table (new-array 32768 t/int32) :type (simple-array t/int32 (32768))))
249+
250+(defmethod print-object ((obj emu-ootake) out)
251+ (print-unreadable-object (obj out :type t)
252+ (format out "Sample rate: ~a" (%ootake-sample-rate obj))))
253+
254+(define-typed-fn ootake-honey-in-the-sky-p ((emu-ootake emu))
255+ (boolean t)
256+ (declare (optimize (speed 3) (debug 1) (safety 0) (compilation-speed 0)))
257+ (%ootake-honey-in-the-sky-p emu))
258+
259+(define-typed-fn (setf ootake-honey-in-the-sky-p) ((boolean value) (emu-ootake emu))
260+ (null t)
261+ (declare (optimize (speed 3) (debug 1) (safety 0) (compilation-speed 0)))
262+ (setf (%ootake-honey-in-the-sky-p emu) value)
263+ nil)
264+
265+(define-typed-fn make-emu-ootake ((t/int32 clock) (integer sample-rate))
266+ (emu-ootake)
267+ (let ((ret (%make-emu-ootake :psg-freq (coerce (logand clock #x7FFFFFFF) 'double-float))))
268+ (setf (%ootake-psg ret) (make-array 8 :element-type 'psg
269+ :initial-contents (loop repeat 8 collect (make-psg))))
270+ (setf (ootake-honey-in-the-sky-p ret) (/= (logand (ash clock -31) #x01) 0))
271+ (%set-volume ret)
272+ (ootake-reset ret)
273+ (%create-volume-table ret)
274+ (%create-noise-table ret)
275+ (setf (%ootake-sample-rate ret) (coerce sample-rate 'double-float))
276+ (setf (%ootake-resample-rate ret) (/ (%ootake-psg-freq ret) +oversample-rate+ (%ootake-sample-rate ret)))
277+ ret))
278+
279+(define-typed-fn %set-vol ((emu-ootake emu))
280+ (null)
281+ (setf (%ootake-vol emu)
282+ (case (%ootake-psg-volume-effect emu)
283+ (0 #.(/ 1.0d0 128.0d0))
284+ (3 (/ (%ootake-volume emu) (/ (* +oversample-rate+ 4.0d0) 3.0d0)))
285+ (otherwise (/ (%ootake-volume emu) (* +oversample-rate+ (%ootake-psg-volume-effect emu))))))
286+ nil)
287+
288+(define-typed-fn %set-volume ((emu-ootake emu))
289+ (null)
290+ (setf (%ootake-volume emu) (/ 1.0d0 +psg-decline+))
291+ (%set-vol emu)
292+ nil)
293+
294+(define-typed-fn %create-volume-table ((emu-ootake emu))
295+ (null)
296+ (setf (aref (%ootake-volume-table emu) 0) 0)
297+ (loop for i fixnum from 1 to 91
298+ for v double-float = (- 91.0d0 i)
299+ do (setf (aref (%ootake-volume-table emu) i)
300+ (coerce-to-int32
301+ (truncate (* 32768.0d0 (expt 10.0d0 (/ (* v +vol-table-decline+) 20.0d0)))))))
302+ nil)
303+
304+(define-typed-fn %create-noise-table ((emu-ootake emu))
305+ (null)
306+ (loop with bit0 fixnum = 0
307+ with bit1 fixnum = 0
308+ with bit14 fixnum = 0
309+ with reg fixnum = #x100
310+ for i fixnum from 0 below 32768 do
311+ (setf bit0 (logand reg 1))
312+ (setf bit1 (ash (logand reg 2) -1))
313+ (setf bit14 (logxor bit0 bit1))
314+ (setf reg (ash reg -1))
315+ (setf reg (logior reg (coerce-to-uint32 (ash bit14 14))))
316+ (setf (aref (%ootake-noise-table emu) i) (if (zerop bit0) -1 -18)))
317+ nil)
318+
319+(define-typed-fn %get-mute-psg-channel ((emu-ootake emu) (fixnum num))
320+ (boolean t)
321+ (declare (optimize (speed 3) (debug 0) (safety 0) (compilation-speed 0)))
322+ (aref (%ootake-psg-mute emu) num))
323+
324+(define-typed-fn %set-mute-psg-channel ((emu-ootake emu) (fixnum num) (boolean mute?))
325+ (null t)
326+ (declare (optimize (speed 3) (debug 0) (safety 0) (compilation-speed 0)))
327+ (setf (aref (%ootake-psg-mute emu) num) mute?)
328+ (when mute?
329+ (setf (aref (%ootake-dda-fade-out-l emu) num) 0)
330+ (setf (aref (%ootake-dda-fade-out-r emu) num) 0))
331+ nil)
332+
333+(define-typed-fn %reset-volume-reg ((emu-ootake emu))
334+ (null)
335+ (declare (optimize (speed 3) (debug 0) (safety 0) (compilation-speed 0)))
336+ (setf (%ootake-main-volume-l emu) 0)
337+ (setf (%ootake-main-volume-r emu) 0)
338+ (loop for i fixnum from 0 below +n-channel+ do
339+ (setf (%psg-volume (aref (%ootake-psg emu) i)) 0)
340+ (setf (%psg-out-volume-l (aref (%ootake-psg emu) i)) 0)
341+ (setf (%psg-out-volume-r (aref (%ootake-psg emu) i)) 0)
342+ (setf (aref (%ootake-dda-fade-out-l emu) i) 0)
343+ (setf (aref (%ootake-dda-fade-out-r emu) i) 0))
344+ nil)
345+
346+(define-typed-fn ootake-reset ((emu-ootake emu))
347+ (null)
348+ (setf (%ootake-psg emu) (make-array 8 :element-type 'psg
349+ :initial-contents (loop repeat 8 collect (make-psg))))
350+ (fill (%ootake-dda-fade-out-l emu) 0)
351+ (fill (%ootake-dda-fade-out-r emu) 0)
352+ (setf (%ootake-main-volume-l emu) 0)
353+ (setf (%ootake-main-volume-r emu) 0)
354+ (setf (%ootake-lfo-freq emu) 0)
355+ (setf (%ootake-lfo-ctrl emu) 0)
356+ (setf (%ootake-channel emu) 0)
357+ (setf (%ootake-wave-crash-p emu) nil)
358+
359+ ;; Kitao更新。v0.65．waveデータを初期化。
360+ (dotimes (i +n-channel+)
361+ (dotimes (j 32)
362+ ;; 最小値で初期化。ファイプロ，フォーメーションサッカー'90，F1トリプルバトルで必要。
363+ (setf (aref (%psg-wave (aref (%ootake-psg emu) i)) j) -14)))
364+
365+ (dotimes (j 32)
366+ ;; ch3は最大値で初期化。F1トリプルバトル。v2.65
367+ (setf (aref (%psg-wave (aref (%ootake-psg emu) 3)) j) -17))
368+ nil)
369+
370+(define-typed-fn ootake-read ((emu-ootake emu) (fixnum reg))
371+ (t/uint8 t)
372+ (declare (optimize (speed 3) (debug 1) (safety 0) (compilation-speed 0)))
373+ (aref (%ootake-port emu) (logand reg 15)))
374+
375+(define-typed-fn ootake-write-reg ((emu-ootake emu) (fixnum reg data))
376+ (null t)
377+ (declare (optimize (speed 3) (debug 1) (safety 0) (compilation-speed 0)))
378+ (let ((freq 0))
379+ (declare (type t/uint32 freq))
380+
381+ (setf (aref (%ootake-port emu) (logand reg 15)) data)
382+
383+ (case (logand reg 15)
384+ (0 ;; Register select
385+ (setf (%ootake-channel emu) (logand data 7)))
386+
387+ (1 ;; Main volume
388+ (setf (%ootake-main-volume-l emu) (logand (ash data -4) #x0F))
389+ (setf (%ootake-main-volume-r emu) (logand data #x0F))
390+
391+ ;; LMAP, RMAL は全チャネルの音量に影響する
392+ (loop for i fixnum from 0 below +n-channel+
393+ for psg-chan = (aref (%ootake-psg emu) i)
394+ do (setf (%psg-out-volume-l psg-chan)
395+ (aref (%ootake-volume-table emu)
396+ (+ (%psg-volume psg-chan)
397+ (* (+ (%ootake-main-volume-l emu) (%psg-volume-l psg-chan)) 2))))
398+ (setf (%psg-out-volume-r psg-chan)
399+ (aref (%ootake-volume-table emu)
400+ (+ (%psg-volume psg-chan)
401+ (* (+ (%ootake-main-volume-r emu) (%psg-volume-r psg-chan)) 2))))))
402+
403+ (2 ;; Frequency low
404+ (let ((psg-chan (aref (%ootake-psg emu) (%ootake-channel emu))))
405+ (logandf (%psg-freq psg-chan) #.(lognot #xFF))
406+ (logiorf (%psg-freq psg-chan) data)
407+
408+ ;; Kitao更新。update_frequencyは、速度アップのためサブルーチンにせず直接実行するようにした。
409+ (setf freq (logand (1- (%psg-freq psg-chan)) #xFFF))
410+ (if (/= freq 0)
411+ ;; Kitao更新。速度アップのためfrq以外は定数計算にした。精度向上のた
412+ ;; め、先に値の小さいOVERSAMPLE_RATEのほうで割るようにした。+0.5は
413+ ;; 四捨五入で精度アップ。プチノイズ軽減のため。
414+ (setf (%psg-delta-phase psg-chan)
415+ (coerce-to-uint32
416+ (truncate (+ (/ (* #.(* 65536.0d0 256.0d0 8.0d0) (%ootake-resample-rate emu)) freq) 0.5d0))))
417+
418+ (setf (%psg-delta-phase psg-chan) 0))))
419+
420+ (3 ;; Frequency high
421+ (let ((psg-chan (aref (%ootake-psg emu) (%ootake-channel emu))))
422+ (logandf (%psg-freq psg-chan) #.(lognot #xF00))
423+ (logiorf (%psg-freq psg-chan) (ash (logand data #x0F) 8))
424+
425+ ;; Kitao更新。update_frequencyは、速度アップのためサブルーチンにせず直接実行するようにした。
426+ (setf freq (logand (1- (%psg-freq psg-chan)) #xFFF))
427+
428+ (if (/= freq 0)
429+ ;; Kitao更新。速度アップのためfrq以外は定数計算にした。精度向上のた
430+ ;; め、先に値の小さいOVERSAMPLE_RATEのほうで割るようにした。+0.5は
431+ ;; 四捨五入で精度アップ。プチノイズ軽減のため。
432+ (setf (%psg-delta-phase psg-chan)
433+ (coerce-to-uint32
434+ (truncate (+ (/ (* #.(* 65536.0d0 256.0d0 8.0d0) (%ootake-resample-rate emu)) freq) 0.5d0))))
435+
436+ (setf (%psg-delta-phase psg-chan) 0))))
437+
438+ (4 ;; ON, DDA, AL
439+ (let ((psg-chan (aref (%ootake-psg emu) (%ootake-channel emu))))
440+ ;; はにいいんざすかいのポーズ時に、微妙なボリューム調整タイミングの問題
441+ ;; でプチノイズが載ってしまうので、現状はパッチ処理で対応。v2.60更新
442+ (when (%ootake-honey-in-the-sky-p emu)
443+ ;; 発声中にdataが0の場合、LRボリュームも0にリセット。はにいいんざすか
444+ ;; いのポーズ時のノイズが解消。(data & 0x1F)だけが0のときにリセットす
445+ ;; ると、サイレントデバッガーズ等でNG。発声してない時にリセットすると
446+ ;; アトミックロボでNG。ｖ2.55
447+ (when (and (%psg-on-p psg-chan) (zerop data))
448+ ;; メインボリュームのbit0が0のときだけ処理(はにいいんざすかいでイレ
449+ ;; ギュラーな0xE。他のゲームは0xF。※ヘビーユニットも0xEだった)。こ
450+ ;; れがないとミズバク大冒険で音が出ない。実機の仕組みと同じかどうか
451+ ;; は未確認。v2.53追加
452+ (unless (flag? (%ootake-main-volume-l emu) 1)
453+ (setf (%psg-volume-l psg-chan) 0))
454+ (unless (flag? (%ootake-main-volume-r emu) 1)
455+ (setf (%psg-volume-r psg-chan) 0))))
456+
457+ (setf (%psg-on-p psg-chan) (flag? data #x80))
458+ ;; DDAからWAVEへ切り替わるとき or DDAから消音するとき
459+ (when (and (%psg-dda-p psg-chan) (not (flag? data #x40)))
460+ ;; Kitao追加。DDAはいきなり消音すると目立つノイズが載るのでフェードアウトする。
461+ ;;
462+ ;; Remi: This has been refactored to be cleaner.
463+ (setf (aref (%ootake-dda-fade-out-l emu) (%ootake-channel emu))
464+ (coerce-to-int32
465+ (truncate
466+ (satou-chips::muffling
467+ (* (%psg-dda-sample psg-chan) (%psg-out-volume-l psg-chan) +sample-fade-decline+)))))
468+ (setf (aref (%ootake-dda-fade-out-r emu) (%ootake-channel emu))
469+ (coerce-to-int32
470+ (truncate
471+ (satou-chips::muffling
472+ (* (%psg-dda-sample psg-chan) (%psg-out-volume-r psg-chan) +sample-fade-decline+))))))
473+
474+ (setf (%psg-dda-p psg-chan) (/= (logand data #x40) 0))
475+
476+ ;; Kitao追加。dataのbit7,6が01のときにWaveインデックスをリセットする。
477+ ;; DDAモード時にWaveデータを書き込んでいた場合はここでWaveデータを修復
478+ ;; （初期化）する。ファイヤープロレスリング。
479+ (when (= (logand data #xC0) #x40)
480+ (setf (%psg-wave-index psg-chan) 0)
481+ (when (%ootake-wave-crash-p emu)
482+ (loop for i fixnum from 0 below 32
483+ do (setf (aref (%psg-wave psg-chan) i) -14) ;; Waveデータを最小値で初期化
484+ finally (setf (%ootake-wave-crash-p emu) nil))))
485+
486+ (setf (%psg-volume psg-chan) (logand data #x1F))
487+ (setf (%psg-out-volume-l psg-chan)
488+ (aref (%ootake-volume-table emu)
489+ (+ (%psg-volume psg-chan) (* (+ (%ootake-main-volume-l emu) (%psg-volume-l psg-chan)) 2))))
490+ (setf (%psg-out-volume-r psg-chan)
491+ (aref (%ootake-volume-table emu)
492+ (+ (%psg-volume psg-chan) (* (+ (%ootake-main-volume-r emu) (%psg-volume-r psg-chan)) 2))))))
493+
494+ (5 ;; LAL, RAL
495+ (let ((psg-chan (aref (%ootake-psg emu) (%ootake-channel emu))))
496+ (setf (%psg-volume-l psg-chan) (logand (ash data -4) #x0F))
497+ (setf (%psg-volume-r psg-chan) (logand data #x0F))
498+ (setf (%psg-out-volume-l psg-chan)
499+ (aref (%ootake-volume-table emu)
500+ (+ (%psg-volume psg-chan) (* (+ (%ootake-main-volume-l emu) (%psg-volume-l psg-chan)) 2))))
501+ (setf (%psg-out-volume-r psg-chan)
502+ (aref (%ootake-volume-table emu)
503+ (+ (%psg-volume psg-chan) (* (+ (%ootake-main-volume-r emu) (%psg-volume-r psg-chan)) 2))))))
504+
505+ (6 ;;wave data. Kitao更新。DDAモードのときもWaveデータを更新するよ うにし
506+ ;;た。v0.63。ファイヤープロレスリング
507+ (let ((psg-chan (aref (%ootake-psg emu) (%ootake-channel emu)))
508+ (new-data (logand data #x1F)))
509+ (setf (%ootake-wave-crash-p emu) nil)
510+
511+ ;; Kitao追加。音を鳴らしていないときだけWaveデータを更新する。v0.65。F1
512+ ;; トリプルバトルのエンジン音。
513+ (unless (%psg-on-p psg-chan)
514+ ;; 17。Kitao更新。一番心地よく響く値に。ミズバク大冒険，モトローダー，
515+ ;; ドラゴンスピリット等で調整。
516+ (setf (aref (%psg-wave psg-chan) (%psg-wave-index psg-chan)) (- 17 new-data))
517+ (incf (%psg-wave-index psg-chan))
518+ (logandf (%psg-wave-index psg-chan) #x1F))
519+
520+ (when (%psg-dda-p psg-chan)
521+ ;; Kitao更新。ノイズ軽減のため6より下側の値はカットするようにした。v0.59
522+ (when (< new-data 6) ;; サイバーナイトで6に決定
523+ (setf new-data 6)) ;; ノイズが多いので小さな値はカット
524+
525+ (setf (%psg-dda-sample psg-chan) (- 11 new-data))
526+
527+ ;; DDAモード時にWaveデータを書き換えた場合
528+ (unless (%psg-on-p psg-chan)
529+ (setf (%ootake-wave-crash-p emu) t)))))
530+
531+ (7 ;; Noise on, noise frequency
532+ (when (>= (%ootake-channel emu) 4)
533+ (let ((psg-chan (aref (%ootake-psg emu) (%ootake-channel emu))))
534+ (setf (%psg-noise-on-p psg-chan) (/= (logand data #x80) 0))
535+ (setf (%psg-noise-freq psg-chan) (- #x1F (logand data #x1F)))
536+ (setf (%psg-delta-noise-phase psg-chan)
537+ (if (zerop (%psg-noise-freq psg-chan))
538+ (coerce-to-uint32 (truncate (+ (* 2048.0d0 (%ootake-resample-rate emu)) 0.5d0)))
539+ (coerce-to-uint32 (truncate (/ (* 2048.0d0 (%ootake-resample-rate emu))
540+ (+ (%psg-noise-freq psg-chan) 0.5d0)))))))))
541+
542+ (8 ;; LFO frequency
543+ (setf (%ootake-lfo-freq emu) data))
544+
545+ (9 ;; LFO control. Kitao更新。シンプルに実装してみた。実機で同じ動作 かは
546+ ;; 未確認。はにいいんざすかいの音が似るように実装。v1.59
547+ (when (flag? data #x80) ;; bit7を立てて呼ぶと恐らくリセット
548+ (setf (%psg-phase (aref (%ootake-psg emu) 1)) 0)) ;; LfoFrqは初期化しない。はにいいんざすかい。
549+
550+ (setf (%ootake-lfo-ctrl emu) (logand data 7)) ;; ドロップロックほらホラで5が使われる。v1.61更新
551+ (when (flag? (%ootake-lfo-ctrl emu) 4)
552+ ;; ドロップロックほらホラ。実機で聴いた感じはLFOオフと同じ音のようなの
553+ ;; でbit2が立っていた(負の数扱い？)ら0と同じこととする。
554+ (setf (%ootake-lfo-ctrl emu) 0)))))
555+ nil)
556+
557+(define-typed-fn ootake-write ((emu-ootake emu) (fixnum reg) (fixnum data))
558+ (null t)
559+ (declare (optimize (speed 3) (debug 1) (safety 0) (compilation-speed 0)))
560+ (ootake-write-reg emu reg data))
561+
562+(define-typed-fn ootake-update ((emu-ootake emu) (satou-chips::t/output-buffer outputs) (t/uint32 start samples))
563+ (null)
564+ (declare (optimize (speed 3) (debug 1) (safety 0) (compilation-speed 0)))
565+ (with-output-buffers (out-l out-r outputs samples "HuC6280")
566+ (let ((sample 0)
567+ (lfo 0)
568+
569+ ;; Kitao追加。6chぶんのサンプルを足していくためのバッファ。精度を維持
570+ ;; するために必要。6chぶん合計が終わった後に、これをSint16に変換して書
571+ ;; き込むようにした。
572+ (sample-all-l 0)
573+
574+ ;; Kitao追加。上のＲチャンネル用
575+ (sample-all-r 0)
576+
577+ ;; Kitao追加。DDA音量,ノイズ音量計算用
578+ (smp 0))
579+ (declare (type fixnum sample lfo sample-all-l sample-all-r smp))
580+
581+ (loop for j fixnum from start below (+ samples start) do
582+ (setf sample-all-l 0)
583+ (setf sample-all-r 0)
584+
585+ (loop for i fixnum from 0 below +n-channel+
586+ for psg-chan = (aref (%ootake-psg emu) i)
587+ do (when (and (%psg-on-p psg-chan)
588+ (or (/= i 1) (zerop (%ootake-lfo-ctrl emu)))
589+ (not (aref (%ootake-psg-mute emu) i)))
590+ (cond
591+ ((%psg-dda-p psg-chan)
592+ ;; Kitao更新。サンプリング音の音量を実機並みに調整。
593+ ;; v2.39,v2.40,v2.62,v2.65再調整した。
594+ (setf smp (* (%psg-dda-sample psg-chan) (%psg-out-volume-l psg-chan)))
595+ (incf sample-all-l (+ smp (ash smp -3) (ash smp -4) (ash smp -5) (ash smp -7)
596+ (ash smp -12) (ash smp -14) (ash smp -15)))
597+ (setf smp (* (%psg-dda-sample psg-chan) (%psg-out-volume-r psg-chan)))
598+ (incf sample-all-r (+ smp (ash smp -3) (ash smp -4) (ash smp -5) (ash smp -7)
599+ (ash smp -12) (ash smp -14) (ash smp -15))))
600+
601+ ((%psg-noise-on-p psg-chan)
602+ (setf sample (aref (%ootake-noise-table emu) (ash (%psg-phase psg-chan) -17)))
603+
604+ ;; Kitao追加。noiseFrq=0(dataに0x1Fが書き込まれた)のときは
605+ ;; 音量が通常の半分とした。（ファイヤープロレスリング３、
606+ ;; パックランド、桃太郎活劇、がんばれゴルフボーイズなど）
607+ (cond
608+ ((zerop (%psg-noise-freq psg-chan))
609+ (setf smp (* sample (%psg-out-volume-l psg-chan)))
610+ ;; (1/2 + 1/4096 + (1/32768 + 1/32768))
611+ (incf sample-all-l (+ (ash smp -1) (ash smp -12) (ash smp -14)))
612+ (setf smp (* sample (%psg-out-volume-r psg-chan)))
613+ (incf sample-all-r (+ (ash smp -1) (ash smp -12) (ash smp -14))))
614+
615+ (t
616+ ;; 通常
617+
618+ ;; Kitao更新。ノイズの音量を実機並みに調整(1 + 1/2048 +
619+ ;; 1/16384 + 1/32768)。この"+1/32768"で絶妙(主観。大魔
620+ ;; 界村,ソルジャーブレイドなど)になる。v2.62更新
621+ (setf smp (* sample (%psg-out-volume-l psg-chan)))
622+ (incf sample-all-l (+ (ash smp -11) (ash smp -14) (ash smp -15)))
623+
624+ ;; Kitao更新。ノイズの音量を実機並みに調整
625+ (setf smp (* sample (%psg-out-volume-r psg-chan)))
626+ (incf sample-all-r (+ (ash smp -11) (ash smp -14) (ash smp -15)))))
627+
628+ (setf (%psg-phase psg-chan)
629+ (coerce-to-uint32 (+ (%psg-phase psg-chan) (%psg-delta-noise-phase psg-chan)))))
630+
631+ ((/= (%psg-delta-phase psg-chan) 0)
632+ ;; Kitao更新。オーバーサンプリングしないようにした。
633+ (setf sample (aref (%psg-wave psg-chan)
634+ (ash (%psg-phase psg-chan) -27)))
635+ (when (< (%psg-freq psg-chan) 128)
636+ ;; 低周波域の音量を制限。ブラッドギアのスタート時などで実機と同
637+ ;; 様の音に。ソルジャーブレイドなども実機に近くなった。v2.03
638+ (decf sample (ash sample -2)))
639+
640+ (incf sample-all-l (* sample (%psg-out-volume-l psg-chan)))
641+ (incf sample-all-r (* sample (%psg-out-volume-r psg-chan)))
642+
643+ ;; Kitao更新。Lfoオンが有効になるようにし、Lfoの掛かり具合
644+ ;; を実機に近づけた。v1.59
645+ (cond
646+ ((and (zerop i) (> (%ootake-lfo-ctrl emu) 0))
647+ ;; _LfoCtrlが1のときに0回シフト(そのまま)で、はにいいんざすかいが実機の音に近い。
648+ ;; _LfoCtrlが3のときに4回シフトで、フラッシュハイダースが実機の音に近い。
649+ (setf lfo (ash (aref (%psg-wave (aref (%ootake-psg emu) 1))
650+ (ash (%psg-phase (aref (%ootake-psg emu) 1)) -27))
651+ (ash (1- (%ootake-lfo-ctrl emu)) 1)))
652+
653+ (setf (%psg-phase (aref (%ootake-psg emu) 0))
654+ (coerce-to-uint32
655+ (+ (%psg-phase (aref (%ootake-psg emu) 0))
656+ (coerce-to-uint32
657+ (truncate (+ (/ (* #.(* 65536.0d0 256.0d0 8.0d0) (%ootake-resample-rate emu))
658+ (the fixnum (+ (%psg-freq (aref (%ootake-psg emu) 0)) lfo)))
659+ 0.5d0))))))
660+
661+ (setf (%psg-phase (aref (%ootake-psg emu) 1))
662+ (coerce-to-uint32
663+ (+ (%psg-phase (aref (%ootake-psg emu) 1))
664+ (coerce-to-uint32
665+ (truncate (+ (/ (* #.(* 65536.0d0 256.0d0 8.0d0) (%ootake-resample-rate emu))
666+ (the fixnum (+ (%psg-freq (aref (%ootake-psg emu) 1)) lfo)))
667+ 0.5d0)))))))
668+
669+ (t
670+ (setf (%psg-phase psg-chan)
671+ (coerce-to-uint32 (+ (%psg-phase psg-chan) (%psg-delta-phase psg-chan)))))))))
672+
673+ (cond
674+ ((> (aref (%ootake-dda-fade-out-l emu) i) 0)
675+ (decf (aref (%ootake-dda-fade-out-l emu) i) 0))
676+ ((< (aref (%ootake-dda-fade-out-l emu) i) 0)
677+ (incf (aref (%ootake-dda-fade-out-l emu) i) 0)))
678+
679+ (cond
680+ ((> (aref (%ootake-dda-fade-out-r emu) i) 0)
681+ (decf (aref (%ootake-dda-fade-out-r emu) i) 0))
682+ ((< (aref (%ootake-dda-fade-out-r emu) i) 0)
683+ (incf (aref (%ootake-dda-fade-out-r emu) i) 0)))
684+
685+ (setf sample-all-l (coerce-to-int32 (+ sample-all-l (aref (%ootake-dda-fade-out-l emu) i))))
686+ (setf sample-all-r (coerce-to-int32 (+ sample-all-r (aref (%ootake-dda-fade-out-r emu) i)))))
687+
688+ ;; Kitao更新。6ch合わさったところで、ボリューム調整してバッファに書き込む。
689+ (setf sample-all-l (truncate (* sample-all-l (%ootake-vol emu))))
690+ (setf sample-all-r (truncate (* sample-all-r (%ootake-vol emu))))
691+ (satou-chips::muffling
692+ (setf (aref out-l j) sample-all-l)
693+ (setf (aref out-r j) sample-all-r)))))
694+ nil)
diff -r 000000000000 -r 98c8a1775355 src/chips/emu-ym2151-mame.lisp
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/chips/emu-ym2151-mame.lisp Wed May 24 02:52:21 2023 -0600
@@ -0,0 +1,732 @@
1+(in-package :satou-chips)
2+
3+(defpackage :satou-chips/ym2151-mame
4+ (:use :common-lisp :cl-sdm :satou :satou-chips)
5+ (:nicknames :ym2151-mame)
6+ (:shadowing-import-from :common-lisp #:write-string))
7+
8+(shadowing-import 'satou::dlog :satou-chips/ym2151-mame)
9+
10+(in-package :satou-chips/ym2151-mame)
11+
12+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
13+;;;
14+;;; Tables and constants.
15+;;;
16+
17+(eval-when (:compile-toplevel :load-toplevel)
18+ (defining-consts
19+ (+sample-bits+ 16)
20+
21+ (+freq-sh+ 16) ;; 16.16 fixed point (frequency calculations)
22+ (+eg-sh+ 16) ;; 16.16 fixed point (envelope generator timing)
23+ (+lfo-sh+ 10) ;; 20.10 fixed point (LFO calculations)
24+ (+timer-sh+ 16) ;; 16.16 fixed point (timers calculations)
25+
26+ (+freq-mask+ (1- (ash 1 +freq-sh+)))
27+
28+ (+env-bits+ 10)
29+ (+env-len+ (ash 1 +env-bits+))
30+ (+env-step+ (/ 128.0d0 +env-len+))
31+
32+ (+max-att-index+ (1- +env-len+)) ;; 1023
33+ (+min-att-index+ 0)
34+
35+ (+eg-att+ 4)
36+ (+eg-dec+ 3)
37+ (+eg-sus+ 2)
38+ (+eg-rel+ 1)
39+ (+eg-off+ 0)
40+
41+ (+sin-bits+ 10)
42+ (+sin-len+ (ash 1 +sin-bits+))
43+ (+sin-mask+ (1- +sin-len+))
44+
45+ (+tl-res-len+ 256) ;; 8 bit addressing (real chip)
46+
47+ (+final-sh+ 0)
48+ (+max-out+ 32767)
49+ (+min-out+ -32768)
50+
51+ (+tl-tab-len+ (* 13 2 +tl-res-len+))
52+ (+env-quiet+ (ash +tl-tab-len+ -3))
53+
54+ (+rate-steps+ 8)
55+
56+ (+eg-inc+
57+ (new-array-with
58+ t/uint8
59+ (vector
60+ ;; cycle: 0 1 2 3 4 5 6 7
61+ 0 1 0 1 0 1 0 1 ;; rates 00..11 0 (increment by 0 or 1)
62+ 0 1 0 1 1 1 0 1 ;; rates 00..11 1
63+ 0 1 1 1 0 1 1 1 ;; rates 00..11 2
64+ 0 1 1 1 1 1 1 1 ;; rates 00..11 3
65+
66+ 1 1 1 1 1 1 1 1 ;; rate 12 0 (increment by 1)
67+ 1 1 1 2 1 1 1 2 ;; rate 12 1
68+ 1 2 1 2 1 2 1 2 ;; rate 12 2
69+ 1 2 2 2 1 2 2 2 ;; rate 12 3
70+
71+ 2 2 2 2 2 2 2 2 ;; rate 13 0 (increment by 2)
72+ 2 2 2 4 2 2 2 4 ;; rate 13 1
73+ 2 4 2 4 2 4 2 4 ;; rate 13 2
74+ 2 4 4 4 2 4 4 4 ;; rate 13 3
75+
76+ 4 4 4 4 4 4 4 4 ;; rate 14 0 (increment by 4)
77+ 4 4 4 8 4 4 4 8 ;; rate 14 1
78+ 4 8 4 8 4 8 4 8 ;; rate 14 2
79+ 4 8 8 8 4 8 8 8 ;; rate 14 3
80+
81+ 8 8 8 8 8 8 8 8 ;; rates 15 0 15 1 15 2 15 3 (increment by 8)
82+ 16 16 16 16 16 16 16 16 ;; rates 15 2 15 3 for attack
83+ 0 0 0 0 0 0 0 0))) ;; infinity rates for attack and decay(s)
84+
85+ ;; Envelope Generator rates (32 + 64 rates + 32 RKS).
86+ (+eg-rate-select+
87+ (new-array-with
88+ t/uint8
89+ (vector
90+ ;; 32 fake (infinite time) rates
91+ (* 18 +rate-steps+) (* 18 +rate-steps+) (* 18 +rate-steps+) (* 18 +rate-steps+) (* 18 +rate-steps+)
92+ (* 18 +rate-steps+) (* 18 +rate-steps+) (* 18 +rate-steps+) (* 18 +rate-steps+) (* 18 +rate-steps+)
93+ (* 18 +rate-steps+) (* 18 +rate-steps+) (* 18 +rate-steps+) (* 18 +rate-steps+) (* 18 +rate-steps+)
94+ (* 18 +rate-steps+) (* 18 +rate-steps+) (* 18 +rate-steps+) (* 18 +rate-steps+) (* 18 +rate-steps+)
95+ (* 18 +rate-steps+) (* 18 +rate-steps+) (* 18 +rate-steps+) (* 18 +rate-steps+) (* 18 +rate-steps+)
96+ (* 18 +rate-steps+) (* 18 +rate-steps+) (* 18 +rate-steps+) (* 18 +rate-steps+) (* 18 +rate-steps+)
97+ (* 18 +rate-steps+) (* 18 +rate-steps+)
98+
99+ ;; rates 00-11
100+ (* 0 +rate-steps+) (* 1 +rate-steps+) (* 2 +rate-steps+) (* 3 +rate-steps+)
101+ (* 0 +rate-steps+) (* 1 +rate-steps+) (* 2 +rate-steps+) (* 3 +rate-steps+)
102+ (* 0 +rate-steps+) (* 1 +rate-steps+) (* 2 +rate-steps+) (* 3 +rate-steps+)
103+ (* 0 +rate-steps+) (* 1 +rate-steps+) (* 2 +rate-steps+) (* 3 +rate-steps+)
104+ (* 0 +rate-steps+) (* 1 +rate-steps+) (* 2 +rate-steps+) (* 3 +rate-steps+)
105+ (* 0 +rate-steps+) (* 1 +rate-steps+) (* 2 +rate-steps+) (* 3 +rate-steps+)
106+ (* 0 +rate-steps+) (* 1 +rate-steps+) (* 2 +rate-steps+) (* 3 +rate-steps+)
107+ (* 0 +rate-steps+) (* 1 +rate-steps+) (* 2 +rate-steps+) (* 3 +rate-steps+)
108+ (* 0 +rate-steps+) (* 1 +rate-steps+) (* 2 +rate-steps+) (* 3 +rate-steps+)
109+ (* 0 +rate-steps+) (* 1 +rate-steps+) (* 2 +rate-steps+) (* 3 +rate-steps+)
110+ (* 0 +rate-steps+) (* 1 +rate-steps+) (* 2 +rate-steps+) (* 3 +rate-steps+)
111+ (* 0 +rate-steps+) (* 1 +rate-steps+) (* 2 +rate-steps+) (* 3 +rate-steps+)
112+
113+ ;; rate 12
114+ (* 4 +rate-steps+) (* 5 +rate-steps+) (* 6 +rate-steps+) (* 7 +rate-steps+)
115+
116+ ;; rate 13
117+ (* 8 +rate-steps+) (* 9 +rate-steps+) (* 10 +rate-steps+) (* 11 +rate-steps+)
118+
119+ ;; rate 14
120+ (* 12 +rate-steps+) (* 13 +rate-steps+) (* 14 +rate-steps+) (* 15 +rate-steps+)
121+
122+ ;; rate 15
123+ (* 16 +rate-steps+) (* 16 +rate-steps+) (* 16 +rate-steps+) (* 16 +rate-steps+)
124+
125+ ;; 32 fake rates (same as 15 3)
126+ (* 16 +rate-steps+) (* 16 +rate-steps+) (* 16 +rate-steps+) (* 16 +rate-steps+) (* 16 +rate-steps+)
127+ (* 16 +rate-steps+) (* 16 +rate-steps+) (* 16 +rate-steps+) (* 16 +rate-steps+) (* 16 +rate-steps+)
128+ (* 16 +rate-steps+) (* 16 +rate-steps+) (* 16 +rate-steps+) (* 16 +rate-steps+) (* 16 +rate-steps+)
129+ (* 16 +rate-steps+) (* 16 +rate-steps+) (* 16 +rate-steps+) (* 16 +rate-steps+) (* 16 +rate-steps+)
130+ (* 16 +rate-steps+) (* 16 +rate-steps+) (* 16 +rate-steps+) (* 16 +rate-steps+) (* 16 +rate-steps+)
131+ (* 16 +rate-steps+) (* 16 +rate-steps+) (* 16 +rate-steps+) (* 16 +rate-steps+) (* 16 +rate-steps+)
132+ (* 16 +rate-steps+) (* 16 +rate-steps+))))
133+
134+ (+eg-rate-shift+
135+ (new-array-with
136+ t/uint8
137+ (vector
138+ ;; 32 infinite time rates
139+ 0 0 0 0 0 0 0 0
140+ 0 0 0 0 0 0 0 0
141+ 0 0 0 0 0 0 0 0
142+ 0 0 0 0 0 0 0 0
143+
144+ ;; rates 00-11
145+ 11 11 11 11
146+ 10 10 10 10
147+ 9 9 9 9
148+ 8 8 8 8
149+ 7 7 7 7
150+ 6 6 6 6
151+ 5 5 5 5
152+ 4 4 4 4
153+ 3 3 3 3
154+ 2 2 2 2
155+ 1 1 1 1
156+ 0 0 0 0
157+
158+ ;; rate 12
159+ 0 0 0 0
160+
161+ ;; rate 13
162+ 0 0 0 0
163+
164+ ;; rate 14
165+ 0 0 0 0
166+
167+ ;; rate 15
168+ 0 0 0 0
169+
170+ ;; 32 dummy rates (same as 15 3)
171+ 0 0 0 0 0 0 0 0
172+ 0 0 0 0 0 0 0 0
173+ 0 0 0 0 0 0 0 0
174+ 0 0 0 0 0 0 0 0)))
175+
176+ ;; DT2 defines offset in cents from base note
177+ ;;
178+ ;; This table defines offset in frequency-deltas table.
179+ ;; User's Manual page 22
180+ ;;
181+ ;; Values below were calculated using formula: value = orig.val / 1.5625
182+ ;;
183+ ;; DT2=0 DT2=1 DT2=2 DT2=3
184+ ;; 0 600 781 950
185+ (+dt2-tab+ (new-array-with t/uint32 #(0 384 500 608)))
186+
187+ ;; DT1 defines offset in Hertz from base note. This table is converted while
188+ ;; initialization... Detune table shown in YM2151 User's Manual is wrong
189+ ;; (verified on the real chip).
190+ (+dt1-tab+
191+ (new-array-with
192+ t/uint8
193+ (vector
194+ ;; DT1=0
195+ 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
196+ 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
197+
198+ ;; DT1=1
199+ 0 0 0 0 1 1 1 1 1 1 1 1 2 2 2 2
200+ 2 3 3 3 4 4 4 5 5 6 6 7 8 8 8 8
201+
202+ ;; DT1=2
203+ 1 1 1 1 2 2 2 2 2 3 3 3 4 4 4 5
204+ 5 6 6 7 8 8 9 10 11 12 13 14 16 16 16 16
205+
206+ ;; DT1=3
207+ 2 2 2 2 2 3 3 3 4 4 4 5 5 6 6 7
208+ 8 8 9 10 11 12 13 14 16 17 19 20 22 22 22 22)))
209+
210+ (+phase-inc-rom+
211+ (new-array-with
212+ t/uint16
213+ (vector
214+ 1299 1300 1301 1302 1303 1304 1305 1306
215+ 1308 1309 1310 1311 1313 1314 1315 1316
216+ 1318 1319 1320 1321 1322 1323 1324 1325
217+ 1327 1328 1329 1330 1332 1333 1334 1335
218+ 1337 1338 1339 1340 1341 1342 1343 1344
219+ 1346 1347 1348 1349 1351 1352 1353 1354
220+ 1356 1357 1358 1359 1361 1362 1363 1364
221+ 1366 1367 1368 1369 1371 1372 1373 1374
222+ 1376 1377 1378 1379 1381 1382 1383 1384
223+ 1386 1387 1388 1389 1391 1392 1393 1394
224+ 1396 1397 1398 1399 1401 1402 1403 1404
225+ 1406 1407 1408 1409 1411 1412 1413 1414
226+ 1416 1417 1418 1419 1421 1422 1423 1424
227+ 1426 1427 1429 1430 1431 1432 1434 1435
228+ 1437 1438 1439 1440 1442 1443 1444 1445
229+ 1447 1448 1449 1450 1452 1453 1454 1455
230+ 1458 1459 1460 1461 1463 1464 1465 1466
231+ 1468 1469 1471 1472 1473 1474 1476 1477
232+ 1479 1480 1481 1482 1484 1485 1486 1487
233+ 1489 1490 1492 1493 1494 1495 1497 1498
234+ 1501 1502 1503 1504 1506 1507 1509 1510
235+ 1512 1513 1514 1515 1517 1518 1520 1521
236+ 1523 1524 1525 1526 1528 1529 1531 1532
237+ 1534 1535 1536 1537 1539 1540 1542 1543
238+ 1545 1546 1547 1548 1550 1551 1553 1554
239+ 1556 1557 1558 1559 1561 1562 1564 1565
240+ 1567 1568 1569 1570 1572 1573 1575 1576
241+ 1578 1579 1580 1581 1583 1584 1586 1587
242+ 1590 1591 1592 1593 1595 1596 1598 1599
243+ 1601 1602 1604 1605 1607 1608 1609 1610
244+ 1613 1614 1615 1616 1618 1619 1621 1622
245+ 1624 1625 1627 1628 1630 1631 1632 1633
246+ 1637 1638 1639 1640 1642 1643 1645 1646
247+ 1648 1649 1651 1652 1654 1655 1656 1657
248+ 1660 1661 1663 1664 1666 1667 1669 1670
249+ 1672 1673 1675 1676 1678 1679 1681 1682
250+ 1685 1686 1688 1689 1691 1692 1694 1695
251+ 1697 1698 1700 1701 1703 1704 1706 1707
252+ 1709 1710 1712 1713 1715 1716 1718 1719
253+ 1721 1722 1724 1725 1727 1728 1730 1731
254+ 1734 1735 1737 1738 1740 1741 1743 1744
255+ 1746 1748 1749 1751 1752 1754 1755 1757
256+ 1759 1760 1762 1763 1765 1766 1768 1769
257+ 1771 1773 1774 1776 1777 1779 1780 1782
258+ 1785 1786 1788 1789 1791 1793 1794 1796
259+ 1798 1799 1801 1802 1804 1806 1807 1809
260+ 1811 1812 1814 1815 1817 1819 1820 1822
261+ 1824 1825 1827 1828 1830 1832 1833 1835
262+ 1837 1838 1840 1841 1843 1845 1846 1848
263+ 1850 1851 1853 1854 1856 1858 1859 1861
264+ 1864 1865 1867 1868 1870 1872 1873 1875
265+ 1877 1879 1880 1882 1884 1885 1887 1888
266+ 1891 1892 1894 1895 1897 1899 1900 1902
267+ 1904 1906 1907 1909 1911 1912 1914 1915
268+ 1918 1919 1921 1923 1925 1926 1928 1930
269+ 1932 1933 1935 1937 1939 1940 1942 1944
270+ 1946 1947 1949 1951 1953 1954 1956 1958
271+ 1960 1961 1963 1965 1967 1968 1970 1972
272+ 1975 1976 1978 1980 1982 1983 1985 1987
273+ 1989 1990 1992 1994 1996 1997 1999 2001
274+ 2003 2004 2006 2008 2010 2011 2013 2015
275+ 2017 2019 2021 2022 2024 2026 2028 2029
276+ 2032 2033 2035 2037 2039 2041 2043 2044
277+ 2047 2048 2050 2052 2054 2056 2058 2059
278+ 2062 2063 2065 2067 2069 2071 2073 2074
279+ 2077 2078 2080 2082 2084 2086 2088 2089
280+ 2092 2093 2095 2097 2099 2101 2103 2104
281+ 2107 2108 2110 2112 2114 2116 2118 2119
282+ 2122 2123 2125 2127 2129 2131 2133 2134
283+ 2137 2139 2141 2142 2145 2146 2148 2150
284+ 2153 2154 2156 2158 2160 2162 2164 2165
285+ 2168 2170 2172 2173 2176 2177 2179 2181
286+ 2185 2186 2188 2190 2192 2194 2196 2197
287+ 2200 2202 2204 2205 2208 2209 2211 2213
288+ 2216 2218 2220 2222 2223 2226 2227 2230
289+ 2232 2234 2236 2238 2239 2242 2243 2246
290+ 2249 2251 2253 2255 2256 2259 2260 2263
291+ 2265 2267 2269 2271 2272 2275 2276 2279
292+ 2281 2283 2285 2287 2288 2291 2292 2295
293+ 2297 2299 2301 2303 2304 2307 2308 2311
294+ 2315 2317 2319 2321 2322 2325 2326 2329
295+ 2331 2333 2335 2337 2338 2341 2342 2345
296+ 2348 2350 2352 2354 2355 2358 2359 2362
297+ 2364 2366 2368 2370 2371 2374 2375 2378
298+ 2382 2384 2386 2388 2389 2392 2393 2396
299+ 2398 2400 2402 2404 2407 2410 2411 2414
300+ 2417 2419 2421 2423 2424 2427 2428 2431
301+ 2433 2435 2437 2439 2442 2445 2446 2449
302+ 2452 2454 2456 2458 2459 2462 2463 2466
303+ 2468 2470 2472 2474 2477 2480 2481 2484
304+ 2488 2490 2492 2494 2495 2498 2499 2502
305+ 2504 2506 2508 2510 2513 2516 2517 2520
306+ 2524 2526 2528 2530 2531 2534 2535 2538
307+ 2540 2542 2544 2546 2549 2552 2553 2556
308+ 2561 2563 2565 2567 2568 2571 2572 2575
309+ 2577 2579 2581 2583 2586 2589 2590 2593)))
310+
311+ (+lfo-noise-waveform+
312+ (new-array-with
313+ t/uint8
314+ (vector
315+ #xFF #xEE #xD3 #x80 #x58 #xDA #x7F #x94 #x9E
316+ #xE3 #xFA #x00 #x4D #xFA #xFF #x6A #x7A #xDE
317+ #x49 #xF6 #x00 #x33 #xBB #x63 #x91 #x60 #x51
318+ #xFF #x00 #xD8 #x7F #xDE #xDC #x73 #x21 #x85
319+ #xB2 #x9C #x5D #x24 #xCD #x91 #x9E #x76 #x7F
320+ #x20 #xFB #xF3 #x00 #xA6 #x3E #x42 #x27 #x69
321+ #xAE #x33 #x45 #x44 #x11 #x41 #x72 #x73 #xDF
322+ #xA2
323+
324+ #x32 #xBD #x7E #xA8 #x13 #xEB #xD3 #x15 #xDD
325+ #xFB #xC9 #x9D #x61 #x2F #xBE #x9D #x23 #x65
326+ #x51 #x6A #x84 #xF9 #xC9 #xD7 #x23 #xBF #x65
327+ #x19 #xDC #x03 #xF3 #x24 #x33 #xB6 #x1E #x57
328+ #x5C #xAC #x25 #x89 #x4D #xC5 #x9C #x99 #x15
329+ #x07 #xCF #xBA #xC5 #x9B #x15 #x4D #x8D #x2A
330+ #x1E #x1F #xEA #x2B #x2F #x64 #xA9 #x50 #x3D
331+ #xAB
332+
333+ #x50 #x77 #xE9 #xC0 #xAC #x6D #x3F #xCA #xCF
334+ #x71 #x7D #x80 #xA6 #xFD #xFF #xB5 #xBD #x6F
335+ #x24 #x7B #x00 #x99 #x5D #xB1 #x48 #xB0 #x28
336+ #x7F #x80 #xEC #xBF #x6F #x6E #x39 #x90 #x42
337+ #xD9 #x4E #x2E #x12 #x66 #xC8 #xCF #x3B #x3F
338+ #x10 #x7D #x79 #x00 #xD3 #x1F #x21 #x93 #x34
339+ #xD7 #x19 #x22 #xA2 #x08 #x20 #xB9 #xB9 #xEF
340+ #x51
341+
342+ #x99 #xDE #xBF #xD4 #x09 #x75 #xE9 #x8A #xEE
343+ #xFD #xE4 #x4E #x30 #x17 #xDF #xCE #x11 #xB2
344+ #x28 #x35 #xC2 #x7C #x64 #xEB #x91 #x5F #x32
345+ #x0C #x6E #x00 #xF9 #x92 #x19 #xDB #x8F #xAB
346+ #xAE #xD6 #x12 #xC4 #x26 #x62 #xCE #xCC #x0A
347+ #x03 #xE7 #xDD #xE2 #x4D #x8A #xA6 #x46 #x95
348+ #x0F #x8F #xF5 #x15 #x97 #x32 #xD4 #x28 #x1E
349+ #x55)))))
350+
351+(declaim (type (simple-array t/uint32 (#.+tl-tab-len+)) *tl-tab*))
352+(defparameter *tl-tab* (new-array +tl-tab-len+ t/uint32))
353+
354+;; Sine wave table in decibel scale.
355+(declaim (type (simple-array t/uint32 (#.+sin-len+)) *sin-tab*))
356+(defparameter *sin-tab* (new-array +sin-len+ t/uint32))
357+
358+;; Translate from D1L to volume index (16 D1L levels)
359+(declaim (type (simple-array t/uint32 (16)) *d1l-tab*))
360+(defparameter *d1l-tab* (new-array 16 t/uint32))
361+
362+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
363+;;;
364+;;; Operator Struct
365+;;;
366+
367+(defstruct (operator (:conc-name %op-))
368+ ;; Accumulated operator phase.
369+ (phase 0 :type t/uint32)
370+
371+ ;; Operator frequency count.
372+ (freq 0 :type t/uint32)
373+
374+ ;; Current detune 1 phase increment/decrement value.
375+ (dt1 0 :type t/int32)
376+
377+ ;; Frequency count multiply.
378+ (mul 0 :type t/uint32)
379+
380+ ;; DT1 index multiplied by 32.
381+ (dt1i 0 :type t/uint32)
382+
383+ ;; Current detune 2 value.
384+ (dt2 0 :type t/uint32)
385+
386+ ;; Operator output "direction".
387+ (connect nil :type (or null sb-alien:alien))
388+
389+ ;;;
390+ ;;; M1 (operator 0) data. Other operators don't use these.
391+ ;;;
392+
393+ ;; Where to put the delayed sample. Only M1 (operator 0) is filled with this
394+ ;; data.
395+ (mem-connect nil :type (or null sb-alien:alien))
396+
397+ ;; Delayed sample value.
398+ (mem-value 0 :type t/int32)
399+
400+ ;;;
401+ ;;; Channel-specific data. Note: Each operator number 0 contains channel
402+ ;;; specific data.
403+ ;;;
404+
405+ ;; Feedback shift value for operator 0 in each channel.
406+ (fb-shift 0 :type t/uint32)
407+
408+ ;; Current operator feedback value (only used by operator 0).
409+ (fb-out-current 0 :type t/int32)
410+
411+ ;; Previous operator feedback value (only used by operator 0).
412+ (fb-out-prev 0 :type t/int32)
413+
414+ ;; Channel KC (copied to all operators).
415+ (kc 0 :type t/uint32)
416+ (kci 0 :type t/uint32) ;; For speedup
417+
418+ ;; Channel PMS.
419+ (pms 0 :type t/uint32)
420+
421+ ;; Channel AMS.
422+ (ams 0 :type t/uint32)
423+
424+ ;;;
425+ ;;; End of channel-specific data.
426+ ;;;
427+
428+ ;; LFO amplitude modulation enable mask.
429+ (am-mask 0 :type t/uint32)
430+
431+ ;; Envelope state: 4 = attack(AR), 3 =decay(D1R), 2 = sustain(D2R), 1 = release(RR), 0 = off.
432+ (state 0 :type t/uint32)
433+
434+ ;; Attack state.
435+ (eg-sh-ar 0 :type t/uint8)
436+
437+ ;; Attack state.
438+ (eg-sel-ar 0 :type t/uint8)
439+
440+ ;; Total attenuation level.
441+ (tl 0 :type t/uint32)
442+
443+ ;; Current envelope attenuation level.
444+ (volume +max-att-index+ :type t/int32)
445+
446+ ;; Decay state.
447+ (eg-sh-d1r 0 :type t/uint8)
448+
449+ ;; Decay state.
450+ (eg-sel-d1r 0 :type t/uint8)
451+
452+ ;; Envelope switches to sustain state after reaching this level.
453+ (d1l 0 :type t/uint32)
454+
455+ ;; Sustain state.
456+ (eg-sh-d2r 0 :type t/uint8)
457+
458+ ;; Sustain state
459+ (eg-sel-d2r 0 :type t/uint8)
460+
461+ ;; Release state
462+ (eg-sh-rr 0 :type t/uint8)
463+
464+ ;; Release state
465+ (eg-sel-rr 0 :type t/uint8)
466+
467+ ;; 0 = last key was KEY OFF, 1 = last key was KEY ON.
468+ (key 0 :type t/uint32)
469+
470+ ;; Key scale.
471+ (ks 0 :type t/uint32)
472+
473+ ;; Attack rate.
474+ (ar 0 :type t/uint32)
475+
476+ ;; Decay rate.
477+ (d1r 0 :type t/uint32)
478+
479+ ;; Sustain rate.
480+ (d2r 0 :type t/uint32)
481+
482+ ;; Release rate.
483+ (rr 0 :type t/uint32))
484+
485+(define-typed-fn %op-key-on ((operator op) (fixnum key-set eg-count))
486+ (null t)
487+ (declare (optimize (speed 3) (debug 1) (compilation-speed 0)
488+ #+(or satou-debug satou-verbose-debug) (safety 1)))
489+ (when (zerop (%op-key op))
490+ (setf (%op-phase op) 0) ;; Clear phase
491+ (setf (%op-state op) +eg-att+) ;; Key On = Attack
492+ (incf (%op-volume op) (ash (* (lognot (%op-volume op))
493+ (aref +eg-inc+ (+ (%op-eg-sel-ar op)
494+ (logand (ash eg-count (- (%op-eg-sh-ar op))) 7))))
495+ -4))
496+
497+ (when (<= (%op-volume op) +min-att-index+)
498+ (setf (%op-volume op) +min-att-index+)
499+ (setf (%op-state op) +eg-dec+)))
500+
501+ (logiorf (%op-key op) key-set)
502+ nil)
503+
504+(define-typed-fn %op-key-off ((operator op) (fixnum key-clr))
505+ (null t)
506+ (declare (optimize (speed 3) (debug 1) (compilation-speed 0)
507+ #+(or satou-debug satou-verbose-debug) (safety 1)))
508+ (unless (zerop (%op-key op))
509+ (logandf (%op-key op) key-clr)
510+ (when (and (zerop (%op-key op))
511+ (> (%op-state op) +eg-rel+)) ;; Key Off = Release
512+ (setf (%op-state op) +eg-rel+)))
513+ nil)
514+
515+(defstruct (emu-ym2151 (:conc-name %emu-)
516+ (:constructor %make-emu-ym2151))
517+
518+ ;; The 32 operators.
519+ (operators (make-array 32 :element-type 'operator
520+ :initial-contents (loop repeat 32 collect (make-operator)))
521+ :type (simple-array operator (32)))
522+
523+ ;; Channel output masks (#xFFFFFFFF = enable).
524+ (pan (new-array 16 t/uint32) :type (simple-array t/uint32 (16)))
525+
526+ ;; Used for muting.
527+ (muted (new-array 8 t/uint8) :type (simple-array t/uint8 (8)))
528+
529+ ;; Global envelope generator counter.
530+ (eg-count 0 :type t/uint32)
531+
532+ ;; Global envelope generator counter works at frequency = chipclock / 64 / 3
533+ (eg-timer 0 :type t/uint32)
534+
535+ ;; Step for egTimer
536+ (eg-timer-add 0 :type t/uint32)
537+
538+ ;; Envelope generator timer overflows every 3 samples (on real chips).
539+ (eg-timer-overflow 0 :type t/uint32)
540+
541+ ;; Accumulated LFO phase (0 to 255)
542+ (lfo-phase 0 :type t/uint32)
543+
544+ ;; LFO timer
545+ (lfo-timer 0 :type t/uint32)
546+
547+ ;; Step of lfoTimer
548+ (lfo-timer-add 0 :type t/uint32)
549+
550+ ;; LFO generates new output when lfoTimer reaches this value.
551+ (lfo-overflow 0 :type t/uint32)
552+
553+ ;; LFO phase increment counter.
554+ (lfo-counter 0 :type t/uint32)
555+
556+ ;; Step for lfoCounter
557+ (lfo-counter-add 0 :type t/uint32)
558+
559+ ;; LFO waveform select (0 = saw, 1 = square, 2 = triangle, 3 = random noise).
560+ (lfo-wsel 0 :type t/uint8)
561+
562+ ;; LFO amplitude modulation depth.
563+ (amd 0 :type t/uint8)
564+
565+ ;; LFO phase modulation depth.
566+ (pmd 0 :type t/int8)
567+
568+ ;; LFO current AM output.
569+ (lfa 0 :type t/uint32)
570+
571+ ;; LFO current PM output.
572+ (lfp 0 :type t/int32)
573+
574+ ;; TEST register.
575+ (test 0 :type t/uint8)
576+
577+ ;; Output control pins (bit1 = CT2, bit0 = CT1).
578+ (ct 0 :type t/uint8)
579+
580+ ;; Noise enable/period register (bit 7 = noise enable, bits 4-0 = noise period).
581+ (noise 0 :type t/uint32)
582+
583+ ;; 17 bit noise shift register.
584+ (noise-rng 0 :type t/uint32)
585+
586+ ;; Current noise 'phase'.
587+ (noise-phase 0 :type t/uint32)
588+
589+ ;; Current noise period.
590+ (noise-f 0 :type t/uint32)
591+
592+ ;; CSM key on/key off sequence request.
593+ (csm-req 0 :type t/uint32)
594+
595+ ;; IRQ enable for timer B (bit 3) and timer A (bit 2). Bit 7 = CSM mode
596+ ;; (key on to all slots, everytime timer A overflows).
597+ (irq-enable 0 :type t/uint32)
598+
599+ ;; Chip status (BUSY, IRQ Flags, etc.)
600+ (status 0 :type t/uint32)
601+
602+ ;; Channels connections.
603+ (connect (new-array 8 t/uint8) :type (simple-array t/uint8 (8)))
604+
605+ ;; Timer A enable (0 = disabled)
606+ (tim-a 0 :type t/uint8)
607+
608+ ;; Timer B enable (0 = disabled)
609+ (tim-b 0 :type t/uint8)
610+
611+ ;; Current value of timer A.
612+ (tim-a-val 0 :type t/int32)
613+
614+ ;; Current value of timer B.
615+ (tim-b-val 0 :type t/int32)
616+
617+ ;; Timer A deltas
618+ (tim-a-tab (new-array 1024 t/uint32) :type (simple-array t/uint32 (1024)))
619+
620+ ;; Timer B deltas
621+ (tim-b-tab (new-array 256 t/uint32) :type (simple-array t/uint32 (256)))
622+
623+ ;; Timer A index.
624+ (timer-a-index 0 :type t/uint32)
625+
626+ ;; Timer B index.
627+ (timer-b-index 0 :type t/uint32)
628+
629+ ;; Timer A previous index.
630+ (timer-a-index-old 0 :type t/uint32)
631+
632+ ;; Timer B previous index.
633+ (timer-b-index-old 0 :type t/uint32)
634+
635+ ;; Frequency-deltas to get the closest frequency possible.
636+ ;; There are 11 octaves because of DT2 (max 950 cents over base frequency)
637+ ;; and LFO phase modulation (max 800 cents below AND over base frequency)
638+ ;; Summary: octave explanation
639+ ;; 0 note code - LFO PM
640+ ;; 1 note code
641+ ;; 2 note code
642+ ;; 3 note code
643+ ;; 4 note code
644+ ;; 5 note code
645+ ;; 6 note code
646+ ;; 7 note code
647+ ;; 8 note code
648+ ;; 9 note code + DT2 + LFO PM
649+ ;; 10 note code + DT2 + LFO PM
650+ ;;
651+ ;; 11 octaves, 768 cents per octave
652+ (freq (new-array #.(* 11 768) t/uint32) :type (simple-array t/uint32 (#.(* 11 768))))
653+
654+ ;; Frequency deltas for DT1. These deltas alter operator frequency after
655+ ;; it has been taken from the frequency-deltas table.
656+ (dt1-freq (new-array #.(* 8 32) t/int32) :type (simple-array t/int32 (#.(* 8 32))))
657+
658+ ;; 17-bit noise generator periods.
659+ (noise-tab (new-array 32 t/uint32) :type (simple-array t/uint32 (32)))
660+
661+ ;; Chip clock in hertz.
662+ (clock 0 :type t/uint32)
663+
664+ ;; Chip sampling frequency in hertz.
665+ (samp-freq 0 :type t/uint32)
666+
667+ ;;
668+ ;; These are for speedup purposes only.
669+ ;;
670+
671+ (chan-out (new-array 8 t/int32) :type (simple-array t/int32 (8)))
672+ (m2 nil :type (or null sb-alien:alien))
673+ (c1 nil :type (or null sb-alien:alien))
674+ (c2 nil :type (or null sb-alien:alien))
675+ (mem nil :type (or null sb-alien:alien)))
676+
677+(define-typed-fn make-emu-ym2151 ((t/uint32 clock rate))
678+ (emu-ym2151)
679+ (let (m2 c1 c2 mem)
680+ (handler-bind
681+ ((error (lambda (err)
682+ ;; Handle any errors that occur during the constructor. We'll
683+ ;; need to ensure the pointers are deallocated here. We don't
684+ ;; handle the error itself, so it's still passed up the stack.
685+ (sdm-log:error! "Error making EMU-YM2151, cleaning up memory: ~a" (type-of err))
686+ (when (and (boundp m2)
687+ (not (sb-alien:null-alien m2)))
688+ (sb-alien:free-alien m2))
689+ (when (and (boundp c1)
690+ (not (sb-alien:null-alien c1)))
691+ (sb-alien:free-alien c1))
692+ (when (and (boundp c2)
693+ (not (sb-alien:null-alien c2)))
694+ (sb-alien:free-alien c2))
695+ (when (and (boundp mem)
696+ (not (sb-alien:null-alien mem)))
697+ (sb-alien:free-alien mem)))))
698+
699+ ;; Allocate the pointers
700+ (setf m2 (sb-alien:make-alien (sb-alien:* (integer 32)) 1))
701+ (setf c1 (sb-alien:make-alien (sb-alien:* (integer 32)) 1))
702+ (setf c2 (sb-alien:make-alien (sb-alien:* (integer 32)) 1))
703+ (setf mem (sb-alien:make-alien (sb-alien:* (integer 32)) 1))
704+
705+ ;; Create the emulator and initialize some values.
706+ (let ((ret (%make-emu-ym2151 :m2 m2 :c1 c1 :c2 c2 :mem mem :clock clock)))
707+ (%emu-init-tables ret)
708+ (setf (%emu-samp-freq ret) (if (/= rate 0) rate 44100))
709+ (%emu-init-chip-tables ret)
710+
711+ (setf (%emu-lfo-timer-add ret)
712+ (coerce-to-uint32 (truncate (/ (* (ash 1 +lfo-sh+) (/ clock 64.0d0)) (%emu-samp-freq ret)))))
713+
714+ (setf (%emu-eg-timer-add ret)
715+ (coerce-to-uint32 (truncate (/ (* (ash 1 +eg-sh+) (/ clock 64.0d0)) (%emu-samp-freq ret)))))
716+
717+ (setf (%emu-eg-timer-overflow ret) (coerce-to-uint32 (* 3 (ash 1 +eg-sh+))))
718+
719+ (%emu-unmute-all ret)
720+
721+ ;; Setup a finalizer, then return
722+ (sb-ext:finalize ret #'(lambda ()
723+ #+satou-verbose-debug (dlog "Running EMU-YM2151 finalizer")
724+ (when (not (sb-alien:null-alien m2))
725+ (sb-alien:free-alien m2))
726+ (when (not (sb-alien:null-alien c1))
727+ (sb-alien:free-alien c1))
728+ (when (not (sb-alien:null-alien c2))
729+ (sb-alien:free-alien c2))
730+ (when (not (sb-alien:null-alien mem))
731+ (sb-alien:free-alien mem))))
732+ ret))))
diff -r 000000000000 -r 98c8a1775355 src/chips/package.lisp
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/chips/package.lisp Wed May 24 02:52:21 2023 -0600
@@ -0,0 +1,15 @@
1+;;;; SatouSynth
2+;;;; Copyright (C) 2023 Remilia Scarlet <remilia@posteo.jp>
3+;;;;
4+;;;; This program is free software: you can redistribute it and/or
5+;;;; modify it under the terms of the GNU Affero General Public
6+;;;; License as published by the Free Software Foundation, either
7+;;;; version 3 of the License, or (at your option) any later version.
8+;;;;
9+;;;; This program is distributed in the hope that it will be useful,
10+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
11+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12+;;;; Affero General Public License for more details.
13+;;;;
14+;;;; You should have received a copy of the GNU Affero General Public License
15+;;;; along with this program. If not, see <https://www.gnu.org/licenses/>.
diff -r 000000000000 -r 98c8a1775355 src/common.lisp
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/common.lisp Wed May 24 02:52:21 2023 -0600
@@ -0,0 +1,231 @@
1+;;;; SatouSynth
2+;;;; Copyright (C) 2023 Remilia Scarlet <remilia@posteo.jp>
3+;;;;
4+;;;; This program is free software: you can redistribute it and/or
5+;;;; modify it under the terms of the GNU Affero General Public
6+;;;; License as published by the Free Software Foundation, either
7+;;;; version 3 of the License, or (at your option) any later version.
8+;;;;
9+;;;; This program is distributed in the hope that it will be useful,
10+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
11+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12+;;;; Affero General Public License for more details.
13+;;;;
14+;;;; You should have received a copy of the GNU Affero General Public License
15+;;;; along with this program. If not, see <https://www.gnu.org/licenses/>.
16+(in-package :satou)
17+
18+(defining-consts
19+ (+default-sample-rate+ 44100 :documentation "The default output sample rate.")
20+ (+min-sample-rate+ 8000 :documentation "The minimum supported output sample rate.")
21+ (+volume-modifier-wrap+ #xC0)
22+ (+vgm-sample-rate+ 44100 :documentation "The rate that commands are sampled in VGM files."))
23+
24+(deftype t/stream-sample ()
25+ 't/int32)
26+
27+(deftype t/output-buffer ()
28+ '(simple-vector 2))
29+
30+(defmacro with-output-buffers ((left right buffers) &body forms)
31+ `(let ((,left (svref ,buffers 0))
32+ (,right (svref ,buffers 1)))
33+ (declare (type t/int32-array ,left ,right))
34+ ,@forms))
35+
36+(declaim (type t/output-buffer *fake-buf*))
37+(defparameter *fake-buf* (vector (new-array 0 t/stream-sample)
38+ (new-array 0 t/stream-sample)))
39+
40+(define-condition satou-error (simple-error)
41+ ()
42+ (:documentation "Base class for all error conditions in SatouSynth."))
43+
44+(defmacro satou-error ((&optional (type ''satou-error)) msg &rest fmt-args)
45+ "Raises a new SATOU-ERROR of the given TYPE, setting the FORMAT-CONTROL and
46+FORMAT-ARGUMENTS of the new condition automatically.
47+
48+TYPE can be quoted or not quoted, but must be SATOU-ERROR or a valid subtype
49+known at expansion time."
50+ (let ((type (if (listp type) type (list 'quote type))))
51+ (unless (subtypep (cadr type) 'satou-error)
52+ (error "Not a subtype of SATOU-ERROR: ~a" type))
53+ `(error ,type :format-control ,msg :format-arguments (list ,@fmt-args))))
54+
55+;; This is re-defined from CL-SDM so that we can setup debugging easier
56+;; throughout the library.
57+(defmacro define-typed-fn (name (&rest arg-list) (ret-type &optional inline) &body forms)
58+ `(sdm:define-typed-fn ,name (,@arg-list)
59+ ;; Override the INLINE parameter. If :SATOU-VERBOSE-DEBUG is in *FEATURES*,
60+ ;; then we always explicitly say :NO _except_ when it's equal to :ALWAYS.
61+ (,ret-type #+satou-verbose-debug ,(if (eq inline :always) t :no)
62+ #-satou-verbose-debug ,inline)
63+ ,@forms))
64+
65+(defmacro dlog (msg &rest fmt-args)
66+ (declare (ignorable msg fmt-args))
67+ #+satou-verbose-debug `(sdm-log:dlog! ,msg ,@fmt-args))
68+
69+(deftype t/sample ()
70+ 'simple-vector)
71+
72+(defmacro sample-left (smp)
73+ `(the t/int32 (svref ,smp 0)))
74+
75+(defmacro sample-right (smp)
76+ `(the t/int32 (svref ,smp 1)))
77+
78+(define-pseudo-enum t/chip integer
79+ ;; Texas Instruments SN76489
80+ (:sn76489 0)
81+
82+ ;; Yamaha YM2413 (OPLL)
83+ (:ym2413 1)
84+
85+ ;; Yamaha YM2612 (OPN2)
86+ (:ym2612 2)
87+
88+ ;; Yamaha YM2151 (OPM)
89+ (:ym2151 3)
90+
91+ ;; Sega SegaPCM (315-5218)
92+ (:sega-pcm 4)
93+
94+ ;; Ricoh RF5C69 (aka RF5C164, RF5C105). RF5C164 has a separate entry.
95+ (:rf5c69 5)
96+
97+ ;; Yamaha YM2203 (OPN)
98+ (:ym2203 6)
99+
100+ ;; Yamaha YM2608 (OPNA)
101+ (:ym2608 7)
102+
103+ ;; Yamaha YM2610 and YM2610B (OPNB)
104+ (:ym2610 8)
105+
106+ ;; Yamaha YM3812 (OPL2)
107+ (:ym3812 9)
108+
109+ ;; Yamaha YM3526 (OPL)
110+ (:ym3526 10)
111+
112+ ;; Yamaha Y8950 (MSX-Audio)
113+ (:y8950 11)
114+
115+ ;; Yamaha YMF262 (OPL3)
116+ (:ymf262 12)
117+
118+ ;; Yamaha YMF278B (OPL4)
119+ (:ymf278b 13)
120+
121+ ;; Yamaha YMF271 (OPX)
122+ (:ymf271 14)
123+
124+ ;; Yamaha YMZ280B (PCMD8)
125+ (:ymz280b 15)
126+
127+ ;; Ricoh RF5C164
128+ (:rf5c164 16)
129+
130+ ;; Sega PWM (32x)
131+ (:pwm 17)
132+
133+ ;; General Instruments AY-1-8910 / AY-3-8910 / AY-3-8912 / AY-3-8913 / Yamaha YM2149 / Yamaha YM2149F
134+ (:ay8910 18)
135+
136+ ;; Nintendo DMG (GameBoy/GameBoy Color)
137+ (:dmg 19)
138+
139+ ;; Nintendo APU (NES)
140+ (:nes-apu 20)
141+
142+ ;; Sega MultiPCM / Yamaha YMW258-F
143+ (:multi-pcm 21)
144+
145+ ;; NEC µPD7759
146+ (:upd7759 22)
147+
148+ ;; OKI M6258
149+ (:oki-m6258 23)
150+
151+ ;; OKI M6295
152+ (:oki-m6295 24)
153+
154+ ;; Konami 051649
155+ (:k051649 25)
156+
157+ ;; Konami 054539
158+ (:k054539 26)
159+
160+ ;; Hudson HuC6280
161+ (:huc6280 27)
162+
163+ ;; Namco C140 / C219
164+ (:c140 28)
165+
166+ ;; Konami 053260
167+ (:k053260 29)
168+
169+ ;; Atari POKEY
170+ (:pokey 30)
171+
172+ ;; QSound DSP16A (Capcom CP System II)
173+ (:qsound 31)
174+
175+ ;; Sega Saturn Custom Sound Processor / Yamaha YMF292
176+ (:scsp 32)
177+
178+ ;; Bandai Wonderswan/Wonderswan Color
179+ (:wonderswan 33)
180+
181+ ;; Nintendo VSU-VUE (Virtual Boy)
182+ (:vsu 34)
183+
184+ ;; Philips SAA1099
185+ (:saa1099 35)
186+
187+ ;; Ensoniq ES5503
188+ (:es5503 36)
189+
190+ ;; Ensoniq ES5506
191+ (:es5506 37)
192+
193+ ;; Namco C352
194+ (:c352 38)
195+
196+ ;; Sega X1-010
197+ (:x1-010 39)
198+
199+ ;; Irem GA20
200+ (:ga20 40)
201+
202+ ;; A special value indicating an uninitialized value.
203+ (:unknown 255))
204+
205+(defmacro muffling (&body forms)
206+ `(locally
207+ (declare #-(or satou-debug satou-verbose-debug) (sb-ext:muffle-conditions sb-ext:compiler-note))
208+ ,@forms))
209+
210+(define-typed-fn get-int32-le ((t/uint8-vector data))
211+ (t/int32 t)
212+ (declare (optimize (speed 3) (safety 0) (compilation-speed 0)
213+ #+satou-debug (debug 1)
214+ #-satou-debug (debug 0)))
215+ (muffling
216+ (coerce-to-int32 (logior (ash (aref data 3) 24)
217+ (ash (aref data 2) 16)
218+ (ash (aref data 1) 8)
219+ (aref data 0)))))
220+
221+(define-typed-fn get-int16-le ((t/uint8-vector data))
222+ (t/int16 t)
223+ (declare (optimize (speed 3) (safety 0) (compilation-speed 0)
224+ #+satou-debug (debug 1)
225+ #-satou-debug (debug 0)))
226+ (muffling
227+ (coerce-to-int16 (logior (ash (aref data 1) 8)
228+ (aref data 0)))))
229+
230+(deftype t/resampler-type ()
231+ '(member :old :upsampling :copy :downsampling))
diff -r 000000000000 -r 98c8a1775355 src/dac-controller.lisp
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/dac-controller.lisp Wed May 24 02:52:21 2023 -0600
@@ -0,0 +1,416 @@
1+;;;; SatouSynth
2+;;;; Copyright (C) 2023 Remilia Scarlet <remilia@posteo.jp>
3+;;;; Based on VGMPlay, Copyright (C) Valley Bell
4+;;;;
5+;;;; This program is free software: you can redistribute it and/or
6+;;;; modify it under the terms of the GNU Affero General Public
7+;;;; License as published by the Free Software Foundation, either
8+;;;; version 3 of the License, or (at your option) any later version.
9+;;;;
10+;;;; This program is distributed in the hope that it will be useful,
11+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13+;;;; Affero General Public License for more details.
14+;;;;
15+;;;; You should have received a copy of the GNU Affero General Public License
16+;;;; along with this program. If not, see <https://www.gnu.org/licenses/>.
17+(in-package :satou)
18+
19+;;;;
20+;;;; DAC Controller
21+;;;;
22+;;;; This code implements the VGM specification for the "DAC Stream Control
23+;;;; Driver". This is used to stream data from data blocks in a VGM file to the
24+;;;; chip emulators via chip writes.
25+;;;;
26+
27+(defpackage :satou/dac
28+ (:use :common-lisp :cl-sdm :satou)
29+ (:shadowing-import-from :common-lisp #:write-string)
30+ (:export
31+ #:dac-controller
32+ #:dac-update
33+ #:dac-get-dac-from-pcm-bank
34+ #:dac-chip-table
35+ #:make-dac-controller
36+ #:dac-add-pcm-data))
37+
38+(eval-when (:compile-toplevel :load-toplevel)
39+ (shadowing-import 'satou::define-typed-fn :satou/dac)
40+ (import 'satou::muffling :satou/dac)
41+ (import 'satou::dlog :satou/dac)
42+ (import 'satou::get-int16-le :satou/dac)
43+ (import 'satou::get-int32-le :satou/dac))
44+
45+(in-package :satou/dac)
46+
47+(defining-consts
48+ (+dac-pcm-bank-count+ #x40)
49+ (+dac-dctrl-lmode-ignore+ 0)
50+ (+dac-dctrl-lmode-cmds+ 1)
51+ (+dac-dctrl-lmode-msec+ 2)
52+ (+dac-dctrl-lmode-to-end+ 3)
53+ (+dac-dctrl-lmode-bytes+ 15))
54+
55+(defstruct bank-table
56+ (compression-type 0 :type t/uint8)
57+ (compression-sub-type 0 :type t/uint8)
58+ (bit-dec 0 :type t/uint8)
59+ (bit-cmp 0 :type t/uint8)
60+ (entry-count 0 :type t/uint16)
61+ (entries (new-array 0 t/uint8) :type t/uint8-array))
62+
63+(defstruct pcm-data
64+ (data-size 0 :type t/uint32)
65+ (data (new-array 0 t/uint8) :type t/uint8-array)
66+ (data-start 0 :type t/uint32))
67+
68+(defstruct pcm-bank
69+ (banks (new-vector pcm-data) :type (vector pcm-data))
70+ (data (new-array 0 t/uint8) :type t/uint8-array)
71+ (data-size 0 :type t/uint32)
72+ (data-pos 0 :type t/uint32)
73+ (bank-pos 0 :type t/uint32))
74+
75+(defstruct control
76+ (dest-chip-type :unknown :type t/chip)
77+ (dest-chip-index 0 :type t/uint8)
78+ (dest-command 0 :type t/uint16)
79+ (command-size 0 :type t/uint8)
80+
81+ ;; The frequency at which the commands are sent, in hertz.
82+ (frequency 0 :type t/uint32)
83+
84+ (data-len 0 :type t/uint32)
85+ (data (new-array 0 t/uint8) :type t/uint8-array)
86+ (data-start 0 :type t/uint32)
87+ (step-size 0 :type t/uint8)
88+ (step-base 0 :type t/uint8)
89+ (commands-to-send 0 :type t/uint32)
90+
91+ ;; Running Bits: 0 (01) - is playing
92+ ;; 2 (04) - loop sample (simple loop from start to end)
93+ ;; 4 (10) - already sent this command
94+ ;; 7 (80) - disabled
95+ (running 0 :type t/uint8)
96+
97+ (reverse 0 :type t/uint8)
98+ (step 0 :type t/uint32)
99+ (pos 0 :type t/uint32)
100+ (remaining-commands 0 :type t/uint32)
101+ (real-pos 0 :type t/uint32)
102+ (data-step 0 :type t/uint8))
103+
104+(defstruct bank-mapping
105+ (chip-type :unknown :type t/chip)
106+ (bank nil :type (or null pcm-bank)))
107+
108+(defstruct (dac-controller (:constructor %make-dac-controller)
109+ (:conc-name %dac-))
110+ (chip-table nil :type (or null hash-table))
111+ (pcm-table (make-bank-table) :type bank-table)
112+
113+ ;; Maps a bank type to a PcmBank instance.
114+ (banks nil :type (or null (simple-array pcm-bank)))
115+
116+ ;; Maps a stream ID to a bank.
117+ (bank-map (make-hash-table) :type hash-table)
118+
119+ (streams (make-hash-table) :type hash-table)
120+ (sample-rate 0 :type t/uint32)
121+ (bank-table (make-bank-table) :type bank-table))
122+
123+(define-typed-fn dac-chip-table ((dac-controller dac))
124+ (hash-table t)
125+ (declare (optimize (speed 3) (debug 1) (safety 0) (compilation-speed 0)))
126+ (%dac-chip-table dac))
127+
128+(define-typed-fn (setf dac-chip-table) ((hash-table value) (dac-controller dac))
129+ (null t)
130+ (declare (optimize (speed 3) (debug 1) (safety 0) (compilation-speed 0)))
131+ (setf (%dac-chip-table dac) value)
132+ nil)
133+
134+(define-typed-fn %control-reset ((control ctrl))
135+ (null)
136+ "Resets the instance to its initial state."
137+ (dlog "Resetting CONTROL for ~a index ~a" (control-dest-chip-type ctrl) (control-dest-chip-index ctrl))
138+ (setf (control-dest-command ctrl) 0)
139+ (setf (control-command-size ctrl) 0)
140+ (setf (control-frequency ctrl) 0)
141+ (setf (control-data-len ctrl) 0)
142+ (setf (control-data ctrl) (new-array 0 t/uint8))
143+ (setf (control-data-start ctrl) 0)
144+ (setf (control-step-size ctrl) 0)
145+ (setf (control-step-base ctrl) 0)
146+ (setf (control-running ctrl) 0)
147+ (setf (control-reverse ctrl) 0)
148+ (setf (control-step ctrl) 0)
149+ (setf (control-pos ctrl) 0)
150+ (setf (control-real-pos ctrl) 0)
151+ (setf (control-remaining-commands ctrl) 0)
152+ (setf (control-data-start ctrl) 0)
153+ nil)
154+
155+(define-typed-fn %control-running-p ((control ctrl))
156+ (boolean t)
157+ "Returns T if the instance is running, or NIL otherwise."
158+ (declare (optimize (speed 3) (debug 1) (safety 0) (compilation-speed 0)))
159+ (not (flag? (control-running ctrl) #x80)))
160+
161+(define-typed-fn %dac-stream-update ((dac-controller dac) (control chip) (t/uint32 sample-count))
162+ (null t)
163+ ;; Is the chip disabled?
164+ (unless (%control-running-p chip) (return-from %dac-stream-update))
165+
166+ ;; Is the chip stopped?
167+ (unless (flag? (control-running chip) #x01) (return-from %dac-stream-update))
168+
169+ ;; TODO
170+ nil)
171+
172+(define-typed-fn %dac-read-pcm-table ((dac-controller dac) (t/uint32 data-size) (t/uint8-array data))
173+ (null)
174+ (declare (optimize (speed 3) (debug 1) (safety 0) (compilation-speed 0)))
175+ (let ((bank-table (%dac-bank-table dac)))
176+ (setf (bank-table-compression-type bank-table) (aref data 0))
177+ (setf (bank-table-compression-sub-type bank-table) (aref data 1))
178+ (setf (bank-table-bit-dec bank-table) (aref data 2))
179+ (setf (bank-table-bit-cmp bank-table) (aref data 3))
180+ (setf (bank-table-entry-count bank-table) (get-int16-le (subseq data 4)))
181+
182+ (let* ((val-size (truncate (coerce-to-uint8 (+ (bank-table-bit-dec bank-table) 7)) 8))
183+ (table-size (coerce-to-uint64 (* (bank-table-entry-count bank-table) val-size))))
184+ (setf (bank-table-entries bank-table) (subseq data 6 (- (length data) (+ 6 table-size))))
185+ (when (< data-size (+ 6 table-size))
186+ (sdm-log:warn! "Bad PCM table length"))))
187+ nil)
188+
189+(defun make-dac-controller (sample-rate)
190+ "Creates a new DAC-CONTROLLER instance."
191+ (let ((ret (%make-dac-controller :sample-rate sample-rate)))
192+ (setf (%dac-banks ret) (make-array +dac-pcm-bank-count+
193+ :element-type 'pcm-bank
194+ :initial-contents (loop repeat +dac-pcm-bank-count+
195+ collect (make-pcm-bank))))
196+ ret))
197+
198+(define-typed-fn dac-update ((dac-controller dac) (t/uint32 sample-count))
199+ (null t)
200+ "Writes data to the chips for SAMPLE-COUNT samples."
201+ (declare (optimize (speed 3) (debug 1) (safety 0) (compilation-speed 0)))
202+ (loop for stream-id being the hash-values in (%dac-streams dac) do
203+ (%dac-stream-update dac stream-id sample-count))
204+ nil)
205+
206+(define-typed-fn dac-reset ((dac-controller dac))
207+ (null)
208+ "Resets the givewn DAC-CONTROLLER to the initial state."
209+ (doseq (bank (%dac-banks dac))
210+ (when bank
211+ (setf (pcm-bank-data-pos bank) 0)
212+ (setf (pcm-bank-bank-pos bank) 0)))
213+ (setf (bank-table-entry-count (%dac-bank-table dac)) 0)
214+ nil)
215+
216+(define-typed-fn dac-stream-enabled-p ((dac-controller dac) (t/uint8 stream-id))
217+ (boolean t)
218+ (declare (optimize (speed 3) (debug 1) (safety 0) (compilation-speed 0)))
219+ (hash-table-contains-p (%dac-streams dac) stream-id))
220+
221+(define-typed-fn dac-reset-stream ((dac-controller dac) (t/uint8 stream-id))
222+ (null t)
223+ (declare (optimize (speed 3) (debug 1) (safety 0) (compilation-speed 0)))
224+ (multiple-value-bind (stream found)
225+ (gethash stream-id (%dac-streams dac))
226+ (when found
227+ (%control-reset stream)))
228+ nil)
229+
230+(define-typed-fn dac-get-dac-from-pcm-bank ((dac-controller dac))
231+ (t/uint8)
232+ (declare (optimize (speed 3) (debug 1) (safety 0) (compilation-speed 0)))
233+ (let* ((bank (aref (%dac-banks dac) 0))
234+ (data-pos (pcm-bank-data-pos bank)))
235+ (if (>= data-pos (pcm-bank-data-size bank))
236+ #x80
237+ (aref (pcm-bank-data bank)
238+ (incf (pcm-bank-data-pos bank))))))
239+
240+(define-typed-fn dac-setup-chip ((dac-controller dac) (t/chip chip-type) (t/uint8 chip-index stream-id)
241+ (t/uint16 command))
242+ (null)
243+ (declare (optimize (speed 3) (debug 1) (safety 0) (compilation-speed 0)))
244+ (dlog "Setting up DAC for type ~a, stream ID ~a, with command ~a" chip-type stream-id command)
245+
246+ (unless (hash-table-contains-p (%dac-bank-map dac) stream-id)
247+ (dlog "Enabling up DAC for type ~a, stream ID ~a, with command ~a" chip-type stream-id command)
248+ (%dac-start-chip-stream dac chip-type chip-index stream-id)
249+ (dac-reset-stream dac stream-id)
250+ (setf (gethash stream-id (%dac-bank-map dac)) (make-bank-mapping :chip-type chip-type)))
251+
252+ (let ((chip (gethash stream-id (%dac-streams dac))))
253+ (setf (control-dest-command chip) command)
254+
255+ (case (control-dest-chip-type chip)
256+ (:sn76489
257+ (setf (control-command-size chip)
258+ (if (flag? (control-dest-command chip) #x10)
259+ 1 ;; Volume write
260+ 2))) ;; Frequency write
261+
262+ (:ym2612
263+ (setf (control-command-size chip) 1))
264+
265+ ((:pwm :qsound)
266+ (setf (control-command-size chip) 2))
267+
268+ (otherwise
269+ (setf (control-command-size chip) 1)))
270+
271+ (setf (control-data-step chip) (* (control-command-size chip) (control-step-size chip))))
272+ nil)
273+
274+(define-typed-fn dac-set-frequency ((dac-controller dac) (t/uint8 stream-id) (t/uint32 frequency))
275+ (null)
276+ (declare (optimize (speed 3) (debug 1) (safety 0) (compilation-speed 0)))
277+ (multiple-value-bind (chip found)
278+ (gethash stream-id (%dac-streams dac))
279+ (when (and found (%control-running-p chip))
280+ (unless (zerop frequency)
281+ (setf (control-step chip) (truncate (* (control-step chip) (control-frequency chip)) frequency)))
282+ (setf (control-frequency chip) frequency)))
283+ nil)
284+
285+(define-typed-fn dac-add-pcm-data ((dac-controller dac) (t/uint8 data-type) (t/uint32 data-size) (t/uint8-array data))
286+ (null)
287+ "Adds PCM data to the given DAC-CONTROLLER instance."
288+ (declare (optimize (speed 3) (debug 1) (safety 1) (compilation-speed 0)))
289+ (let ((bank-type (logand data-type #x3F)))
290+ ;;(when (> bank-type +dac-pcm-bank-count+)
291+ ;; (return-from dac-add-pcm-data))
292+
293+ (when (= data-type #x7F)
294+ (%dac-read-pcm-table dac data-size data)
295+ (return-from dac-add-pcm-data))
296+
297+ (let ((temp-pcm (aref (%dac-banks dac) bank-type))
298+ (cur-bank 0)
299+ (bank-size 0))
300+ (declare (type t/int32 cur-bank)
301+ (type t/uint32 bank-size))
302+ (incf (pcm-bank-bank-pos temp-pcm))
303+
304+ ;; Speed hack for restarting playback (skip already loaded data)
305+ (when (<= (pcm-bank-bank-pos temp-pcm) (length (pcm-bank-banks temp-pcm)))
306+ (return-from dac-add-pcm-data))
307+
308+ (setf cur-bank (length (pcm-bank-banks temp-pcm)))
309+ (vector-push-extend (make-pcm-data) (pcm-bank-banks temp-pcm))
310+
311+ (setf bank-size (if (not (flag? data-type #x40))
312+ data-size
313+ (coerce-to-uint32 (get-int32-le (subseq data 1)))))
314+
315+ ;; Akin to realloc
316+ (setf (pcm-bank-data temp-pcm)
317+ (make-array (+ (pcm-bank-data-size temp-pcm) bank-size)
318+ :element-type 't/uint8
319+ :initial-contents (concatenate 'vector
320+ (pcm-bank-data temp-pcm)
321+ (loop repeat (- (+ (pcm-bank-data-size temp-pcm) bank-size)
322+ (length (pcm-bank-data temp-pcm)))
323+ collect 0))))
324+
325+ (let ((temp-bank (muffling (aref (pcm-bank-banks temp-pcm) cur-bank))))
326+ (setf (pcm-data-data-start temp-bank) (pcm-bank-data-size temp-pcm))
327+
328+ (cond
329+ ((not (flag? data-type #x40))
330+ (setf (pcm-data-data-size temp-bank) data-size)
331+ (setf (pcm-data-data temp-bank) (subseq (pcm-bank-data temp-pcm) (pcm-data-data-start temp-bank)))
332+ (dotimes (i data-size)
333+ (setf (aref (pcm-data-data temp-bank) i) (aref data i))))
334+
335+ (t
336+ (setf (pcm-data-data temp-bank) (subseq (pcm-bank-data temp-pcm) (pcm-data-data-start temp-bank)))
337+ (unless (%dac-decompress-data-block dac temp-bank data-size data)
338+ (sdm-log:warn! "Decompression of DAC PCM data failed")
339+ (setf (pcm-data-data temp-bank) (new-array 0 t/uint8))
340+ (setf (pcm-data-data-size temp-bank) 0)
341+ (loop for chip being the hash-values in (%dac-streams dac)
342+ do (dac-refresh-data dac chip (pcm-bank-data temp-pcm)))
343+ (return-from dac-add-pcm-data))))
344+
345+ (when (/= bank-size (pcm-data-data-size temp-bank))
346+ (satou-error () "Error reading data block: data size conflict"))
347+
348+ (incf (pcm-bank-data-size temp-pcm) bank-size)
349+ (loop for chip being the hash-values in (%dac-streams dac)
350+ do (dac-refresh-data dac chip (pcm-bank-data temp-pcm))))))
351+ nil)
352+
353+(define-typed-fn dac-bank-count ((dac-controller dac) (t/uint8 stream-id))
354+ (t/uint32 t)
355+ (declare (optimize (speed 3) (debug 1) (safety 0) (compilation-speed 0)))
356+ (length (pcm-bank-banks (bank-mapping-bank (gethash stream-id (%dac-bank-map dac))))))
357+
358+(define-typed-fn %dac-set-data ((dac-controller dac) (t/uint8 stream-id) (t/uint8-array data)
359+ (t/uint8 step-size step-base))
360+ (null)
361+ (declare (optimize (speed 3) (debug 1) (safety 1) (compilation-speed 0)))
362+ (let ((chip (gethash stream-id (%dac-streams dac))))
363+ (when (%control-running-p chip)
364+ (cond
365+ ((> (length data) 0)
366+ (setf (control-data-len chip) (length data))
367+ (setf (control-data chip) data))
368+ (t
369+ (setf (control-data-len chip) 0)
370+ (setf (control-data chip) (new-array 0 t/uint8))))
371+
372+ (setf (control-step-size chip) (if (zerop step-size) 1 step-size))
373+ (setf (control-step-base chip) step-base)
374+ (setf (control-data-step chip) (* (control-command-size chip) (control-step-size chip)))))
375+ nil)
376+
377+(define-typed-fn dac-refresh-data ((dac-controller dac) (control chip) (t/uint8-array data))
378+ (null)
379+ (declare (optimize (speed 3) (debug 1) (safety 1) (compilation-speed 0))
380+ (ignore dac))
381+ (when (%control-running-p chip)
382+ (cond
383+ ((> (length data) 0)
384+ (setf (control-data-len chip) (length data))
385+ (setf (control-data chip) data))
386+ (t
387+ (setf (control-data-len chip) 0)
388+ (setf (control-data chip) (new-array 0 t/uint8)))))
389+ nil)
390+
391+(define-typed-fn dac-assign-pcm-data ((dac-controller dac) (t/uint8 stream-id bank-id step-size step-base))
392+ (null)
393+ "Assigns PCM data from the given bank ID to the given stream ID."
394+ (declare (optimize (speed 3) (debug 1) (safety 1) (compilation-speed 0)))
395+ (let ((bank (aref (%dac-banks dac) (if (>= bank-id +dac-pcm-bank-count+) 0 bank-id))))
396+ (setf (bank-mapping-bank (gethash stream-id (%dac-bank-map dac))) bank)
397+ (%dac-set-data dac stream-id (pcm-bank-data bank) step-size step-base))
398+ nil)
399+
400+
401+;; TODO playBlock
402+
403+(define-typed-fn %dac-start-chip-stream ((dac-controller dac) (t/chip chip-type) (t/uint8 chip-index stream-id))
404+ (null)
405+ (declare (optimize (speed 3) (debug 1) (safety 1) (compilation-speed 0)))
406+ (let ((ctrl (make-control :dest-chip-type chip-type
407+ :dest-chip-index chip-index
408+ :dest-command 0
409+ :running #xFF))) ;; Disables all actions
410+ (setf (gethash stream-id (%dac-streams dac)) ctrl))
411+ nil)
412+
413+(define-typed-fn %dac-decompress-data-block ((dac-controller dac) (pcm-data bank) (t/uint32 data-size)
414+ (t/uint8-array data))
415+ (boolean)
416+ nil)
diff -r 000000000000 -r 98c8a1775355 src/gd3-tag.lisp
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/gd3-tag.lisp Wed May 24 02:52:21 2023 -0600
@@ -0,0 +1,157 @@
1+;;;; SatouSynth
2+;;;; Copyright (C) 2023 Remilia Scarlet <remilia@posteo.jp>
3+;;;;
4+;;;; This program is free software: you can redistribute it and/or
5+;;;; modify it under the terms of the GNU Affero General Public
6+;;;; License as published by the Free Software Foundation, either
7+;;;; version 3 of the License, or (at your option) any later version.
8+;;;;
9+;;;; This program is distributed in the hope that it will be useful,
10+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
11+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12+;;;; Affero General Public License for more details.
13+;;;;
14+;;;; You should have received a copy of the GNU Affero General Public License
15+;;;; along with this program. If not, see <https://www.gnu.org/licenses/>.
16+(in-package :satou)
17+
18+(defining-consts
19+ (+gd3-magic+ "Gd3 " :documentation "Magic bytes for the GD3 tag data.")
20+ (+gd3-version+ (bytes->uint '(0 1 0 0)) :documentation "The supported version of the GD3 tag specification."))
21+
22+(defclass gd3-tag ()
23+ ((version
24+ :initform +gd3-version+
25+ :type t/uint32
26+ :reader gd3-tag-version
27+ :documentation "The version of this GD3 tag data.")
28+
29+ (track-name-en
30+ :initarg :track-name-en
31+ :initform ""
32+ :type string
33+ :accessor gd3-tag-track-name-en
34+ :documentation "The name of the track, in English.")
35+
36+ (track-name-jp
37+ :initarg :track-name-jp
38+ :initform ""
39+ :type string
40+ :accessor gd3-tag-track-name-jp
41+ :documentation "The name of the track, in Japanese.")
42+
43+ (game-name-en
44+ :initarg :game-name-en
45+ :initform ""
46+ :type string
47+ :accessor gd3-tag-game-name-en
48+ :documentation "The name of the game, in English.")
49+
50+ (game-name-jp
51+ :initarg :game-name-jp
52+ :initform ""
53+ :type string
54+ :accessor gd3-tag-game-name-jp
55+ :documentation "The name of the game, in Japanese.")
56+
57+ (system-name-en
58+ :initarg :system-name-en
59+ :initform ""
60+ :type string
61+ :accessor gd3-tag-system-name-en
62+ :documentation "The name of the system, in English.")
63+
64+ (system-name-jp
65+ :initarg :system-name-jp
66+ :initform ""
67+ :type string
68+ :accessor gd3-tag-system-name-jp
69+ :documentation "The name of the system, in Japanese.")
70+
71+ (author-name-en
72+ :initarg :author-name-en
73+ :initform ""
74+ :type string
75+ :accessor gd3-tag-author-name-en
76+ :documentation "The name of the author, in English.")
77+
78+ (author-name-jp
79+ :initarg :author-name-jp
80+ :initform ""
81+ :type string
82+ :accessor gd3-tag-author-name-jp
83+ :documentation "The name of the author, in Japanese.")
84+
85+ (release-date
86+ :initarg :release-date
87+ :initform ""
88+ :type string
89+ :accessor gd3-tag-release-date
90+ :documentation "The track's original release date.")
91+
92+ (creator
93+ :initarg :creator
94+ :initform ""
95+ :type string
96+ :accessor gd3-tag-creator
97+ :documentation "The creator of the VGM file.")
98+
99+ (notes
100+ :initarg :notes
101+ :initform ""
102+ :type string
103+ :accessor gd3-tag-notes
104+ :documentation "Any additional notes about the song or VGM file."))
105+ (:documentation "a GD3 tag stores metadata for a VGM file. It is analogous to
106+an ID3 tag in an MP3 file."))
107+
108+(define-condition gd3-tag-error (satou-error)
109+ ())
110+
111+(define-typed-fn %read-wchar-string ((stream stream))
112+ (simple-string t)
113+ "Reads a C++-like wchar string from STREAM."
114+ (declare (optimize (speed 3) (debug 0) (safety 0) (compilation-speed 0)))
115+ ;; The COERCE might not be needed here?
116+ (coerce (with-output-to-string (out)
117+ (loop for ch fixnum = (read-uint16 stream)
118+ until (= ch 0) do
119+ (write-char (code-char ch) out)))
120+ 'simple-string))
121+
122+(defun read-gd3-tag (stream)
123+ "Creates a new GD3-TAG instance by reading data from STREAM, which should
124+already be at the position of the raw GD3 data."
125+ (unless (equalp (read-string stream (length +gd3-magic+)) +gd3-magic+)
126+ (satou-error (gd3-tag-error) "No valid GD3 tag header found"))
127+
128+ (let ((ret (make-instance 'gd3-tag))
129+ (len 0)
130+ (started-at 0))
131+ (declare (type t/uint32 len)
132+ (type fixnum started-at))
133+ (unless (= (setf (slot-value ret 'version) (read-uint32 stream)) +gd3-version+)
134+ (sdm-log:warn! "GD3 tag version doesn't match what is expected: read $~4,'0x, expected $~4,'0x"
135+ (slot-value ret 'version)
136+ +gd3-version+))
137+
138+ (setf len (read-uint32 stream))
139+ (setf started-at (file-position stream))
140+
141+ (setf (gd3-tag-track-name-en ret) (%read-wchar-string stream))
142+ (setf (gd3-tag-track-name-jp ret) (%read-wchar-string stream))
143+ (setf (gd3-tag-game-name-en ret) (%read-wchar-string stream))
144+ (setf (gd3-tag-game-name-jp ret) (%read-wchar-string stream))
145+ (setf (gd3-tag-system-name-en ret) (%read-wchar-string stream))
146+ (setf (gd3-tag-system-name-jp ret) (%read-wchar-string stream))
147+ (setf (gd3-tag-author-name-en ret) (%read-wchar-string stream))
148+ (setf (gd3-tag-author-name-jp ret) (%read-wchar-string stream))
149+ (setf (gd3-tag-release-date ret) (%read-wchar-string stream))
150+ (setf (gd3-tag-creator ret) (%read-wchar-string stream))
151+ (setf (gd3-tag-notes ret) (%read-wchar-string stream))
152+
153+ (muffling
154+ (unless (= (file-position stream) (the fixnum (+ started-at len)))
155+ (sdm-log:warn! "GD3 tag data size mismatch: ~a != ~a" len (- (file-position stream) started-at))))
156+
157+ ret))
diff -r 000000000000 -r 98c8a1775355 src/package.lisp
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/package.lisp Wed May 24 02:52:21 2023 -0600
@@ -0,0 +1,209 @@
1+;;;; SatouSynth
2+;;;; Copyright (C) 2023 Remilia Scarlet <remilia@posteo.jp>
3+;;;;
4+;;;; This program is free software: you can redistribute it and/or
5+;;;; modify it under the terms of the GNU Affero General Public
6+;;;; License as published by the Free Software Foundation, either
7+;;;; version 3 of the License, or (at your option) any later version.
8+;;;;
9+;;;; This program is distributed in the hope that it will be useful,
10+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
11+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12+;;;; Affero General Public License for more details.
13+;;;;
14+;;;; You should have received a copy of the GNU Affero General Public License
15+;;;; along with this program. If not, see <https://www.gnu.org/licenses/>.
16+
17+(defpackage :satou
18+ (:use :common-lisp :cl-sdm)
19+ (:shadowing-import-from :common-lisp #:write-string)
20+ (:shadow #:define-typed-fn)
21+ (:export
22+ ;; common.lisp
23+ #:satou-error
24+ #:t/chip
25+
26+ ;; abstract-chip
27+ #:chip-type
28+ #:chip-name
29+ #:chip-short-name
30+ #:chip-id
31+ #:chip-emu-core
32+ #:chip-default-emu-core
33+ #:chip-base-volume
34+ #:chip-emu
35+ #:chip-start
36+ #:chip-clock
37+ #:chip-start-flags
38+ #:chip-update
39+ #:chip-update-paired
40+ #:chip-reset
41+ #:chip-read
42+ #:chip-write
43+ #:chip-mute-mask
44+ #:chip-write-dac
45+ #:chip-stereo-mask
46+ #:chip-volume-modifier
47+ #:chip-init
48+ #:chip-write-rom
49+ #:chip-flags
50+ #:abstract-chip
51+ #:chip-sample-rate
52+ #:chip-player-sample-rate
53+ #:chip-volume
54+ #:chip-resampler-type
55+ #:chip-is-paired-p
56+ #:get-chip-volume
57+ #:change-chip-sample-rate
58+
59+ ;; gd3-tag.lisp
60+ #:gd3-tag
61+ #:gd3-tag-version
62+ #:gd3-tag-track-name-en
63+ #:gd3-tag-track-name-jp
64+ #:gd3-tag-game-name-en
65+ #:gd3-tag-game-name-jp
66+ #:gd3-tag-system-name-en
67+ #:gd3-tag-system-name-jp
68+ #:gd3-tag-author-name-en
69+ #:gd3-tag-author-name-jp
70+ #:gd3-tag-release-date
71+ #:gd3-tag-creator
72+ #:gd3-tag-notes
73+ #:gd3-tag-error
74+ #:read-gd3-tag
75+
76+ ;; vgmfile.lisp
77+ #:vgm-error
78+ #:valid-vgm-p
79+ #:read-vgm-file
80+ #:extra-header-clock
81+ #:extra-header-clock-chip-id
82+ #:extra-header-clock-value
83+ #:extra-header-volume
84+ #:extra-header-volume-chip-id
85+ #:extra-header-volume-flags
86+ #:extra-header-volume-value
87+ #:extra-header
88+ #:extra-header-clocks
89+ #:extra-header-volumes
90+ #:vgm-file-header
91+ #:vgm-header-version
92+ #:vgm-header-sn76489-clock
93+ #:vgm-header-ym2413-clock
94+ #:vgm-header-gd3-offset
95+ #:vgm-header-total-samples
96+ #:vgm-header-loop-offset
97+ #:vgm-header-loop-samples
98+ #:vgm-header-rate
99+ #:vgm-header-sn76489-feedback
100+ #:vgm-header-sn76489-shift-register-width
101+ #:vgm-header-sn76489-flags
102+ #:vgm-header-ym2612-clock
103+ #:vgm-header-ym2151-clock
104+ #:vgm-header-data-offset
105+ #:vgm-header-spcm-clock
106+ #:vgm-header-spcm-interface-reg
107+ #:vgm-header-rf5c69-clock
108+ #:vgm-header-ym2203-clock
109+ #:vgm-header-ym2608-clock
110+ #:vgm-header-ym2610-clock
111+ #:vgm-header-ym3812-clock
112+ #:vgm-header-ym3526-clock
113+ #:vgm-header-y8950-clock
114+ #:vgm-header-ymf262-clock
115+ #:vgm-header-ymf278b-clock
116+ #:vgm-header-ymf271-clock
117+ #:vgm-header-ymz280b-clock
118+ #:vgm-header-rf5c164-clock
119+ #:vgm-header-pwm-clock
120+ #:vgm-header-ay8910-clock
121+ #:vgm-header-ay8910-chip-type
122+ #:vgm-header-ay8910-flags
123+ #:vgm-header-ay-ym2203-flags
124+ #:vgm-header-ay-ym2608-flags
125+ #:vgm-header-volume-modifier
126+ #:vgm-header-loop-base
127+ #:vgm-header-loop-modifier
128+ #:vgm-header-dmg-clock
129+ #:vgm-header-nes-apu-clock
130+ #:vgm-header-multi-pcm-clock
131+ #:vgm-header-upd7759-clock
132+ #:vgm-header-oki-m6258-clock
133+ #:vgm-header-oki-m6258-flags
134+ #:vgm-header-k054539-flags
135+ #:vgm-header-c140-chip-type
136+ #:vgm-header-oki-m6295-clock
137+ #:vgm-header-k051649-clock
138+ #:vgm-header-k054539-clock
139+ #:vgm-header-huc6280-clock
140+ #:vgm-header-c140-clock
141+ #:vgm-header-k053260-clock
142+ #:vgm-header-pokey-clock
143+ #:vgm-header-qsound-clock
144+ #:vgm-header-scsp-clock
145+ #:vgm-header-extra-header-offset
146+ #:vgm-header-wonderswan-clock
147+ #:vgm-header-vsu-clock
148+ #:vgm-header-saa1099-clock
149+ #:vgm-header-es5503-clock
150+ #:vgm-header-es5506-clock
151+ #:vgm-header-es5503-num-channels
152+ #:vgm-header-es5506-num-channels
153+ #:vgm-header-c352-clock-div
154+ #:vgm-header-x10-010-clock
155+ #:vgm-header-c352-clock
156+ #:vgm-header-ga20-clock
157+ #:vgm-file
158+ #:vgm-file-header
159+ #:vgm-file-gd3
160+ #:vgm-file-data
161+ #:vgm-file-data-offset
162+ #:vgm-file-extra-header
163+ #:vgm-file-version
164+ #:make-vgm-file
165+ #:vgm-file-chip-used-p
166+ #:vgm-file-get-chip-clock
167+ #:vgm-file-chips-used
168+
169+ ;; vgm-player.lisp
170+ #:vgm-player
171+ #:make-vgm-player
172+ #:vgm-player-reset
173+ #:vgm-player-play
174+ #:vgm-player-render
175+ #:vgm-player-stop
176+ #:vgm-player-get-chip-names
177+ #:vgm-player-chips-used
178+ #:vgm-player-settings
179+ #:vgm-player-vgm
180+ #:vgm-player-sample-rate
181+ #:vgm-player-min-buffer-size
182+ #:vgm-player-play-time
183+ #:vgm-player-main-volume
184+ #:vgm-player-at-end-p
185+ #:vgm-player-times-played
186+ #:vgm-player-chip-table
187+ #:vgm-player-samples-per-buffer
188+ #:vgm-player-volume-modifier
189+ #:vgm-player-playing-p
190+ #:calc-resampling-values
191+ #:calc-resampling-values*))
192+
193+(defpackage :satou-chips
194+ (:use :common-lisp :cl-sdm :satou)
195+ (:shadowing-import-from :common-lisp #:write-string)
196+ (:export
197+ #:with-output-buffers
198+
199+ #:+chip-id/huc6280+
200+ #:t/huc6280-core
201+ #:huc6280
202+
203+ #:+chip-id/c352+
204+ #:t/c352-core
205+ #:c352))
206+
207+(shadowing-import 'satou::define-typed-fn :satou-chips)
208+(import 'satou::t/output-buffer :satou-chips)
209+(import 'satou::muffling :satou-chips)
diff -r 000000000000 -r 98c8a1775355 src/resampler.lisp
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/resampler.lisp Wed May 24 02:52:21 2023 -0600
@@ -0,0 +1,356 @@
1+;;;; SatouSynth
2+;;;; Copyright (C) 2023 Remilia Scarlet <remilia@posteo.jp>
3+;;;; Based on VGMPlay, Copyright (C) Valley Bell
4+;;;;
5+;;;; This program is free software: you can redistribute it and/or
6+;;;; modify it under the terms of the GNU Affero General Public
7+;;;; License as published by the Free Software Foundation, either
8+;;;; version 3 of the License, or (at your option) any later version.
9+;;;;
10+;;;; This program is distributed in the hope that it will be useful,
11+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13+;;;; Affero General Public License for more details.
14+;;;;
15+;;;; You should have received a copy of the GNU Affero General Public License
16+;;;; along with this program. If not, see <https://www.gnu.org/licenses/>.
17+(in-package :satou)
18+
19+;;;;
20+;;;; Fixed-point resampler. This implements four modes: low-quality (but fast)
21+;;;; resampling, upsampling, downsampling, and copying.
22+;;;;
23+;;;; The resampler is where SatouSynth actually calls the update functions for
24+;;;; the chips.
25+;;;;
26+;;;; Note: Nearly all of this code was ported from VGMPlay.
27+;;;;
28+
29+(deftype t/slint ()
30+ 't/uint32)
31+
32+(declaim (type t/uint32 +resampler-bits+ +resampler-fact+ +resampler-mask+))
33+(defining-consts
34+ ;;;
35+ ;;; Fixed Point Constants for Resampler
36+ ;;;
37+
38+ ;; Could be changed. 11 bits seems good and accurate, though. Change the
39+ ;; SLInt alias to UInt64 if this goes above 11, though. Also change the
40+ ;; .to_u32! code in the resamplers as needed.
41+ (+resampler-bits+ 11)
42+
43+ (+resampler-fact+ (ash 1 +resampler-bits+))
44+ (+resampler-mask+ (1- +resampler-fact+)))
45+
46+(defstruct resampler
47+ ;; Playback sample rate
48+ (sample-rate 0 :type t/uint32)
49+
50+ ;; PCM data from the chips get put into this buffer when we updae the chips.
51+ (stream-buffers nil :type (or null t/output-buffer))
52+
53+ ;; Holds sub buffers (see WITH-STREAM-POINT)
54+ (stream-point (vector nil nil) :type (simple-vector 2)))
55+
56+;;;
57+;;; Fixed Point Functions and Utilities
58+;;;
59+
60+(define-typed-fn %get-fraction ((t/uint32 x))
61+ (t/uint32 t)
62+ (declare (optimize (speed 3) (debug 0) (safety 0) (compilation-speed 0)))
63+ (logand x +resampler-mask+))
64+
65+(define-typed-fn %get-n-fraction ((t/uint32 x))
66+ (t/uint32 t)
67+ (declare (optimize (speed 3) (debug 0) (safety 0) (compilation-speed 0)))
68+ (logand (- +resampler-fact+ x) +resampler-mask+))
69+
70+(define-typed-fn %fp2i-floor ((t/uint32 x))
71+ (t/uint32 t)
72+ (declare (optimize (speed 3) (debug 0) (safety 0) (compilation-speed 0)))
73+ (truncate x +resampler-fact+))
74+
75+(define-typed-fn %fp2i-ceil ((t/uint32 x))
76+ (t/uint32 t)
77+ (declare (optimize (speed 3) (debug 0) (safety 0) (compilation-speed 0)))
78+ (truncate (+ x +resampler-mask+) +resampler-fact+))
79+
80+(defmacro with-stream-point ((var left right rs) &body forms)
81+ `(let ((,var (resampler-stream-point ,rs)))
82+ (setf (svref ,var 0) ,left)
83+ (setf (svref ,var 1) ,right)
84+ ,@forms))
85+
86+;;;
87+;;; Resampling Functions
88+;;;
89+
90+(define-typed-fn %resampler-old ((resampler rs) (abstract-chip chip) (simple-vector smp) (t/uint32 len))
91+ (null)
92+ "Low-quality, but fast, resampling."
93+ (declare (ignore rs chip smp len))
94+ (error "Not implemented")
95+ nil)
96+
97+(define-typed-fn %resampler-upsample ((resampler rs) (abstract-chip chip) (simple-vector smp) (t/uint32 len))
98+ (null)
99+ "High quality upsampling."
100+ (declare (ignore len)
101+ (optimize (speed 3) (debug 1) (safety 1) (compilation-speed 0)))
102+ (with-output-buffers (cur-buf-l cur-buf-r (resampler-stream-buffers rs))
103+ (with-typed-slots ((t/uint32 cur-sample-num next-sample-num last-sample-num)
104+ (t/uint16 volume)
105+ (t/sample last-sample next-sample)
106+ ((or null function) update-fn))
107+ chip
108+ (let* ((chip-sample-rate (chip-sample-rate chip))
109+ (in-pos-l (coerce-to-uint32
110+ (truncate (muffling
111+ (* +resampler-fact+ cur-sample-num chip-sample-rate))
112+ (resampler-sample-rate rs))))
113+ (in-pre (%fp2i-floor in-pos-l))
114+ (in-now (%fp2i-ceil in-pos-l))
115+ (in-pos 0)
116+ (sample-fraction 0)
117+ (temp-sample-l 0)
118+ (temp-sample-r 0)
119+ (in-base 0)
120+ (sample-count +resampler-fact+))
121+ (declare (type t/uint64 chip-sample-rate)
122+ (type t/slint in-pos-l)
123+ (type t/uint32 in-pre in-now in-pos sample-fraction in-base sample-count)
124+ (type t/int64 temp-sample-l temp-sample-r))
125+
126+ (setf (aref cur-buf-l 0) (sample-left last-sample))
127+ (setf (aref cur-buf-r 0) (sample-right last-sample))
128+ (setf (aref cur-buf-l 1) (sample-left next-sample))
129+ (setf (aref cur-buf-r 1) (sample-right next-sample))
130+
131+ (with-stream-point (stream-point cur-buf-l cur-buf-r rs)
132+ (if update-fn
133+ (funcall (the function update-fn) chip stream-point 2 (- in-now next-sample-num))
134+ (chip-update chip stream-point 2 (- in-now next-sample-num)))
135+
136+ (setf in-base (coerce-to-uint32 (+ +resampler-fact+ (- in-pos-l (* next-sample-num +resampler-fact+)))))
137+ (setf last-sample-num in-pre)
138+ (setf next-sample-num in-now)
139+
140+ ;; The original code expects us to have an array of return samples.
141+ ;; However, the resampler is only ever called with a single element.
142+ ;; In the interest of efficiency, the len parameter is ignored here,
143+ ;; with the original code is commented out.
144+
145+ ;; (loop for out-pos fixnum from 0 below len do
146+ ;; (setf in-pos (+ in-base (truncate (* +resampler-fact+ out-pos chip-sample-rate)
147+ ;; (resampler-sample-rate rs))))
148+ (setf in-pos in-base)
149+ (setf in-pre (%fp2i-floor in-pos))
150+ (setf in-now (%fp2i-ceil in-pos))
151+ (setf sample-fraction (%get-fraction in-pos))
152+
153+ ;; Linear interpolation
154+ (setf temp-sample-l (+ (* (aref cur-buf-l in-pre) (- +resampler-fact+ sample-fraction))
155+ (* (aref cur-buf-l in-now) sample-fraction)))
156+ (setf temp-sample-r (+ (* (aref cur-buf-r in-pre) (- +resampler-fact+ sample-fraction))
157+ (* (aref cur-buf-r in-now) sample-fraction)))
158+
159+ ;; (incf (sample-left (aref smp out-pos))
160+ ;; (coerce-to-int32 (truncate (* temp-sample-l volume) sample-count)))
161+ ;; (incf (sample-right (aref smp out-pos))
162+ ;; (coerce-to-int32 (truncate (* temp-sample-r volume) sample-count)))
163+
164+ (incf (sample-left smp) (coerce-to-int32 (truncate (* temp-sample-l volume) sample-count)))
165+ (incf (sample-right smp) (coerce-to-int32 (truncate (* temp-sample-r volume) sample-count)))
166+ ;;)
167+
168+ (setf (sample-left last-sample) (aref cur-buf-l in-pre))
169+ (setf (sample-right last-sample) (aref cur-buf-r in-pre))
170+ (setf (sample-left next-sample) (aref cur-buf-l in-now))
171+ (setf (sample-right next-sample) (aref cur-buf-r in-now))
172+ (incf cur-sample-num)))))
173+ nil)
174+
175+(define-typed-fn %resampler-copy ((resampler rs) (abstract-chip chip) (simple-vector smp) (t/uint32 len))
176+ (null t)
177+ "Not actually resampling, just copies data from the chip's output buffer to
178+our destination buffer and applies volume. This is used for situations where
179+the ratio of chip's output sample rate and the playback rate matches 1:1."
180+ (declare (optimize (speed 3) (debug 1) (safety 0) (compilation-speed 0)))
181+ (with-output-buffers (cur-buf-l cur-buf-r (resampler-stream-buffers rs))
182+ (with-typed-slots ((t/uint32 sample-rate cur-sample-num last-sample-num next-sample-num)
183+ (t/uint16 volume)
184+ ((or null function) update-fn))
185+ chip
186+
187+ (setf next-sample-num (coerce-to-uint32 (truncate (* cur-sample-num sample-rate) (resampler-sample-rate rs))))
188+
189+ (if update-fn
190+ (funcall (the function update-fn) chip (resampler-stream-buffers rs) 0 len)
191+ (chip-update chip (resampler-stream-buffers rs) 0 len))
192+
193+ ;; The original code expects us to have an array of return samples.
194+ ;; However, the resampler is only ever called with a single element.
195+ ;; In the interest of efficiency, the len parameter is ignored here,
196+ ;; with the original code is commented out.
197+
198+ ;; (loop for out-pos fixnum from 0 below len do
199+ ;; (incf (sample-left (aref smp out-pos)) (* (aref cur-buf-l 0) volume))
200+ ;; (incf (sample-right (aref smp out-pos)) (* (aref cur-buf-r 0) volume))
201+
202+ (incf (sample-left smp) (* (aref cur-buf-l 0) volume))
203+ (incf (sample-right smp) (* (aref cur-buf-r 0) volume))
204+ ;;)
205+
206+ (incf cur-sample-num len)
207+ (setf last-sample-num next-sample-num)
208+ nil)))
209+
210+(define-typed-fn %resampler-downsample ((resampler rs) (abstract-chip chip) (simple-vector smp) (t/uint32 len))
211+ (null)
212+ "High quality downsampling."
213+ (declare (optimize (speed 3) (debug 1) (safety 1) (compilation-speed 0)))
214+ (with-output-buffers (cur-buf-l cur-buf-r (resampler-stream-buffers rs))
215+ (with-typed-slots ((t/uint32 cur-sample-num next-sample-num last-sample-num)
216+ (t/uint16 volume)
217+ (t/sample last-sample next-sample)
218+ ((or null function) update-fn))
219+ chip
220+ (let* ((chip-sample-rate (chip-sample-rate chip))
221+ (in-pos-l (coerce-to-uint32
222+ (truncate (muffling
223+ (* +resampler-fact+ (+ cur-sample-num len) chip-sample-rate))
224+ (resampler-sample-rate rs))))
225+ (sample-fraction 0)
226+ (temp-sample-l 0)
227+ (temp-sample-r 0)
228+ (in-pre 0)
229+ (in-now 0)
230+ (in-base 0)
231+ (in-pos-next 0)
232+ (in-pos 0)
233+ (sample-count +resampler-fact+))
234+ (declare (type t/uint64 chip-sample-rate)
235+ (type t/slint in-pos-l)
236+ (type t/uint32 in-base in-pos in-pos-next in-pre in-now sample-fraction sample-count)
237+ (type t/int64 temp-sample-l temp-sample-r))
238+
239+ (setf next-sample-num (%fp2i-ceil in-pos-l))
240+ (setf (aref cur-buf-l 0) (sample-left last-sample))
241+ (setf (aref cur-buf-r 0) (sample-right last-sample))
242+
243+ (with-stream-point (stream-point cur-buf-l cur-buf-r rs)
244+ (if update-fn
245+ (funcall (the function update-fn) chip stream-point 1 (- next-sample-num last-sample-num))
246+ (chip-update chip stream-point 1 (- next-sample-num last-sample-num)))
247+
248+ (setf in-pos-l (coerce-to-uint32
249+ (truncate (muffling (* +resampler-fact+ cur-sample-num chip-sample-rate))
250+ (resampler-sample-rate rs))))
251+
252+ ;; Add 1.0 to avoid negative indicies.
253+ (setf in-base (coerce-to-uint32 (+ +resampler-fact+ (- in-pos-l (* last-sample-num +resampler-fact+)))))
254+ (setf in-pos-next in-base)
255+
256+ ;; The original code expects us to have an array of return samples.
257+ ;; However, the resampler is only ever called with a single element.
258+ ;; In the interest of efficiency, the len parameter is ignored here,
259+ ;; with the original code is commented out.
260+
261+ ;; (loop for out-pos fixnum from 0 below len do
262+ ;; (setf in-pos (+ in-base (truncate (* +resampler-fact+ out-pos chip-sample-rate)
263+ ;; (resampler-sample-rate rs))))
264+ (setf in-pos in-pos-next)
265+ ;; (setf in-pos-next (+ in-base (coerce-to-uint32
266+ ;; (truncate (* +resampler-fact+ (1+ out-pos) chip-sample-rate)
267+ ;; (resampler-sample-rate rs)))))
268+ (setf in-pos-next (+ in-base (coerce-to-uint32
269+ (truncate (muffling (* +resampler-fact+ chip-sample-rate))
270+ (resampler-sample-rate rs)))))
271+
272+ ;; First fractional sample
273+ (setf sample-fraction (%get-n-fraction in-pos))
274+ (cond
275+ ((not (zerop sample-fraction))
276+ (setf in-pre (%fp2i-floor in-pos))
277+ (setf temp-sample-l (* (aref cur-buf-l in-pre) sample-fraction))
278+ (setf temp-sample-r (* (aref cur-buf-r in-pre) sample-fraction)))
279+
280+ (t
281+ (setf temp-sample-l 0)
282+ (setf temp-sample-r 0)))
283+ (setf sample-count sample-fraction)
284+
285+ ;; Last fractional sample
286+ (setf sample-fraction (%get-fraction in-pos-next))
287+ (setf in-pre (%fp2i-floor in-pos-next))
288+ (unless (zerop sample-fraction)
289+ (incf temp-sample-l (* (aref cur-buf-l in-pre) sample-fraction))
290+ (incf temp-sample-r (* (aref cur-buf-r in-pre) sample-fraction))
291+ (incf sample-count sample-fraction))
292+
293+ ;; Whole samples in-between
294+ (setf in-now (%fp2i-ceil in-pos))
295+ (incf sample-count (* (- in-pre in-now) +resampler-fact+))
296+ (loop while (< in-now in-pre) do
297+ (incf temp-sample-l (* (aref cur-buf-l in-now) +resampler-fact+))
298+ (incf temp-sample-r (* (aref cur-buf-r in-now) +resampler-fact+))
299+ (incf in-now))
300+
301+ ;; (incf (sample-left (aref smp out-pos))
302+ ;; (coerce-to-int32 (truncate (* temp-sample-l volume) sample-count)))
303+ ;; (incf (sample-right (aref smp out-pos))
304+ ;; (coerce-to-int32 (truncate (* temp-sample-r volume) sample-count)))
305+
306+ (muffling
307+ (incf (sample-left smp) (coerce-to-int32 (truncate (* temp-sample-l volume) sample-count)))
308+ (incf (sample-right smp) (coerce-to-int32 (truncate (* temp-sample-r volume) sample-count))))
309+ ;;)
310+
311+ (setf (sample-left last-sample) (aref cur-buf-l in-pre))
312+ (setf (sample-right last-sample) (aref cur-buf-r in-pre))
313+ ;; (incf cur-sample-num len)
314+ (incf cur-sample-num)
315+ (setf last-sample-num next-sample-num)))))
316+ nil)
317+
318+(define-typed-fn resampler-resample ((resampler rs) (hash-table chip-table) (simple-vector smp) (t/uint32 len))
319+ (null)
320+ "Resamples audio data to SMP. In all cases, LEN should be 1."
321+ (declare (optimize (speed 3) (debug 1) (safety 0) (compilation-speed 0)))
322+ #+satou-debug (unless (= len 1)
323+ (error "LEN is not 1"))
324+
325+ ;; Update and resample all of the chips.
326+ (with-each-chip (chip chip-table)
327+ (with-typed-slots ((t/uint32 last-sample-num sample-rate next-sample-num cur-sample-num)
328+ (boolean is-paired?)
329+ ((or null abstract-chip) paired))
330+ chip
331+ (ecase (chip-resampler-type chip)
332+ (:old (%resampler-old rs chip smp len))
333+ (:upsampling (%resampler-upsample rs chip smp len))
334+ (:copy (%resampler-copy rs chip smp len))
335+ (:downsampling (%resampler-downsample rs chip smp len)))
336+
337+ (when (>= last-sample-num sample-rate)
338+ (decf last-sample-num sample-rate)
339+ (decf next-sample-num sample-rate)
340+ (setf cur-sample-num (- cur-sample-num (resampler-sample-rate rs))))
341+
342+ ;; TODO ensure this doesn't update a chip twice.
343+ (when (chip-is-paired-p chip)
344+ (with-typed-slots ((t/uint32 last-sample-num sample-rate next-sample-num cur-sample-num))
345+ paired
346+ (ecase (chip-resampler-type paired)
347+ (:old (%resampler-old rs paired smp len))
348+ (:upsampling (%resampler-upsample rs paired smp len))
349+ (:copy (%resampler-copy rs paired smp len))
350+ (:downsampling (%resampler-downsample rs paired smp len)))
351+
352+ (when (>= last-sample-num sample-rate)
353+ (decf last-sample-num sample-rate)
354+ (decf next-sample-num sample-rate)
355+ (setf cur-sample-num (- cur-sample-num (resampler-sample-rate rs))))))))
356+ nil)
diff -r 000000000000 -r 98c8a1775355 src/vgm-decompression.lisp
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/vgm-decompression.lisp Wed May 24 02:52:21 2023 -0600
@@ -0,0 +1,247 @@
1+;;;; SatouSynth
2+;;;; Copyright (C) 2023 Remilia Scarlet <remilia@posteo.jp>
3+;;;;
4+;;;; This program is free software: you can redistribute it and/or
5+;;;; modify it under the terms of the GNU Affero General Public
6+;;;; License as published by the Free Software Foundation, either
7+;;;; version 3 of the License, or (at your option) any later version.
8+;;;;
9+;;;; This program is distributed in the hope that it will be useful,
10+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
11+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12+;;;; Affero General Public License for more details.
13+;;;;
14+;;;; You should have received a copy of the GNU Affero General Public License
15+;;;; along with this program. If not, see <https://www.gnu.org/licenses/>.
16+(in-package :satou)
17+
18+;;;;
19+;;;; VGM Decompression System
20+;;;;
21+;;;; This system is used to decompress VGM files, and allows for decompression
22+;;;; methods beyond the standard GZip compression. It is designed to be
23+;;;; extensible.
24+;;;;
25+
26+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
27+;;;
28+;;; Package Definition
29+;;;
30+
31+(defpackage :satou/decompression
32+ (:use :common-lisp :satou :cl-sdm)
33+ (:shadowing-import-from :common-lisp #:write-string)
34+ (:export
35+ #:t/extension-list
36+ #:func-set
37+ #:func-set-extensions
38+ #:func-set-checker
39+ #:func-set-decompressor
40+ #:all-known-schemes
41+ #:get-func-set
42+ #:duplicate-func-set-error
43+ #:register
44+ #:maybe-decompress
45+ #:get-hint))
46+
47+(in-package :satou/decompression)
48+
49+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
50+;;;
51+;;; Core Decompression System
52+;;;
53+
54+(defun %all-simple-string-p (list)
55+ (every #'(lambda (x)
56+ (typep x 'simple-string))
57+ list))
58+
59+(deftype t/extension-list ()
60+ '(and list (satisfies %all-simple-string-p)))
61+
62+(defstruct func-set
63+ (extensions '() :type t/extension-list)
64+ (checker nil :type (or null function))
65+ (decompressor nil :type (or null function)))
66+
67+(define-condition duplicate-func-set-error (satou-error)
68+ ())
69+
70+(declaim (type hash-table *functions*))
71+(defparameter *functions* (make-hash-table :synchronized t))
72+
73+(defun get-func-set (ident)
74+ "Checks to see if IDENT is a FUNC-SET that has been registered using REGISTER.
75+IDENT should be a keyword representing a FUNC-SET, though this is not checked
76+internally."
77+ (nth-value 0 (gethash ident *functions* nil)))
78+
79+(defun all-known-schemes ()
80+ "Returns all of the identifiers for the currently registered decompression
81+schemes as a list of KEYWORDs."
82+ (loop for k being the hash-keys in *functions*
83+ collect k))
84+
85+(defun register (ident check-fn decomp-fn &rest extensions)
86+ "Registers a new method for checking for compressed data, and decompressing
87+that data. IDENT can be used to reference the FUNC-SET using GET-FUNC-SET after
88+registering.
89+
90+EXTENSIONS must consist entirely of strings, and is a set of file extensions
91+that can be used by GET-HINT for this compression scheme. The extensions should
92+not include the leading period, and should be entirely lowercase, e.g. \"vgz\".
93+EXTENSIONS cannot contain the string \"vgm\", regardless of case.
94+
95+CHECK-FN must be a function that accepts a single argument (an open stream), and
96+returns a generalized boolean indicating whether the stream contains compressed
97+data or not.
98+
99+DECOMP-FN must be a function that accepts a single argument (an open stream),
100+and returns a FLEXI-STREAMS:IN-MEMORY-STREAM that is ready to be read from and
101+that contains the decompressed data.
102+
103+Note that IDENT cannot be :NONE."
104+ ;; Do a few checks
105+ (check-type ident symbol)
106+ (check-type check-fn function)
107+ (check-type decomp-fn function)
108+ (unless (keywordp ident) (error "IDENT must be a keyword"))
109+ (unless (every #'stringp extensions) (error "EXTENSIONS must consist entirely of strings."))
110+ (when (eq ident :none) (error "IDENT cannot be :NONE"))
111+ (when (= (length extensions) 0) (error "EXTENSIONS cannot be empty"))
112+ (when (find "vgm" extensions :test #'caseless-string=)
113+ (error "EXTENSIONS cannot contain the extension 'vgm'"))
114+
115+ (when (hash-table-contains-p *functions* ident)
116+ (restart-case
117+ (satou-error (duplicate-func-set-error) "Duplicate decompression function set found: ~a" ident)
118+ (replace-fn-set ()
119+ :report "Replace current function set"
120+ #+satou-verbose-debug (sdm-log:warn! "Replacing compression method: ~a" ident)
121+ (remhash ident *functions*))))
122+
123+ (setf (gethash ident *functions*) (make-func-set :extensions (mapcar #'(lambda (x)
124+ (coerce x 'simple-string))
125+ extensions)
126+ :checker check-fn
127+ :decompressor decomp-fn))
128+
129+ #+satou-verbose-debug (sdm-log:dlog! "Registered compression method: ~a (~{~a~^, ~})" ident extensions)
130+ ident)
131+
132+(defun maybe-decompress (stream &optional hint)
133+ "Checks to see if STREAM needs to be decompressed. If it does, this
134+decompresses the stream into RAM. This then returns either a
135+FLEXI-STREAMS:IN-MEMORY-STREAM that can be used to read uncompressed data, or
136+the original STREAM if it was not compressed. STREAM must support
137+FILE-POSITION.
138+
139+If HINT is provided and is keyword representing a known decompression
140+scheme (see GET-FUNC-SET), then that scheme will be tried first to offer a
141+speedup in load times. You can get a hint by using GET-HINT."
142+ (declare (optimize (speed 3) (debug 1) (compilation-speed 0) (safety 1)))
143+ (check-type hint (or null symbol))
144+
145+ (satou::muffling
146+ (let ((start-pos (file-position stream)))
147+ ;; If we have a hint, then see if we can decompress the data using that
148+ ;; hint.
149+ (when hint
150+ (unless (keywordp hint) (error "HINT must be a KEYWORD"))
151+ (when (eq hint :none) (error "HINT cannot be :NONE"))
152+ (multiple-value-bind (hinted-set found)
153+ (gethash hint *functions*)
154+
155+ ;; We have a hint, let's see if the stream contains compressed data
156+ ;; matching the hint.
157+ (when (and found (funcall (func-set-checker hinted-set) stream))
158+ ;; Hint was successful, rewind to the initial position and decompress.
159+ (file-position stream start-pos)
160+ (return-from maybe-decompress (funcall (func-set-decompressor hinted-set) stream)))))
161+
162+ ;; The hint was not successful, or not provided. Check all known
163+ ;; compression methods.
164+ (file-position stream start-pos) ;; Ensure we're at the correct position.
165+ (maphash #'(lambda (key fn-set)
166+ (declare (ignore key))
167+ (when (funcall (func-set-checker fn-set) stream)
168+ ;; Compressed data detected, decompress and return.
169+ (file-position stream start-pos)
170+ (return-from maybe-decompress (funcall (func-set-decompressor fn-set) stream))))
171+ *functions*)
172+
173+ ;; Not compressed with a known method, return the original stream.
174+ (file-position stream start-pos)
175+ stream)))
176+
177+(defun get-hint (filename)
178+ "Looks at the extension of FILENAME using PATHNAME-TYPE and attempts to guess
179+the compression method (if any). This will return a KEYWORD if it was able to
180+guess, or NIL otherwise.
181+
182+If a keyword is returned, it will reference one of the registered compression
183+methods (see GET-FUNC-SET and REGISTER). This keyword can then be passed to
184+MAYBE-DECOMPRESS.
185+
186+This returns NIL if it thinks that FILENAME is an uncompressed VGM file."
187+ (check-type filename (or string pathname))
188+ (let ((ext (string-downcase (pathname-type filename))))
189+ (maphash #'(lambda (ident set)
190+ (when (find ext (func-set-extensions set) :test #'string=)
191+ ;; Found a known extension.
192+ (return-from get-hint ident)))
193+ *functions*))
194+ ;; Extension was not found, or it's uncompressed.
195+ nil)
196+
197+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
198+;;;
199+;;; GZip Compression Handling
200+;;;
201+
202+(defun %gzipped-p (stream)
203+ (let ((buf (new-array 3 t/uint8))
204+ (pos (file-position stream)))
205+ (unwind-protect
206+ (read-sequence buf stream)
207+ (file-position stream pos))
208+ (and (= (aref buf 0) #x1F)
209+ (= (aref buf 1) #x8B)
210+ (= (aref buf 2) #x08))))
211+
212+(defun %decompress-gzipped-stream (stream)
213+ (flex:make-in-memory-input-stream (chipz:decompress nil 'chipz:gzip stream)))
214+
215+(handler-bind
216+ ((duplicate-func-set-error
217+ (lambda (err)
218+ (declare (ignore err))
219+ (invoke-restart 'replace-fn-set))))
220+ (register :gzip #'%gzipped-p #'%decompress-gzipped-stream "vgz" "gz"))
221+
222+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
223+;;;
224+;;; BZip2 Compression Handling
225+;;;
226+
227+(defun %bzip2-compressed-p (stream)
228+ (let ((buf (new-array 4 t/uint8))
229+ (pos (file-position stream)))
230+ (unwind-protect
231+ (read-sequence buf stream)
232+ (file-position stream pos))
233+ (and (= (aref buf 0) #.(char-code #\B))
234+ (= (aref buf 1) #.(char-code #\Z))
235+ (= (aref buf 2) #.(char-code #\h))
236+ (and (>= (aref buf 3) #.(char-code #\1))
237+ (<= (aref buf 3) #.(char-code #\9))))))
238+
239+(defun %decompress-bzip2-stream (stream)
240+ (flex:make-in-memory-input-stream (chipz:decompress nil 'chipz:bzip2 stream)))
241+
242+(handler-bind
243+ ((duplicate-func-set-error
244+ (lambda (err)
245+ (declare (ignore err))
246+ (invoke-restart 'replace-fn-set))))
247+ (register :bzip2 #'%bzip2-compressed-p #'%decompress-bzip2-stream "vgb" "bz2"))
diff -r 000000000000 -r 98c8a1775355 src/vgm-player-settings.lisp
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/vgm-player-settings.lisp Wed May 24 02:52:21 2023 -0600
@@ -0,0 +1,76 @@
1+;;;; SatouSynth
2+;;;; Copyright (C) 2023 Remilia Scarlet <remilia@posteo.jp>
3+;;;;
4+;;;; This program is free software: you can redistribute it and/or
5+;;;; modify it under the terms of the GNU Affero General Public
6+;;;; License as published by the Free Software Foundation, either
7+;;;; version 3 of the License, or (at your option) any later version.
8+;;;;
9+;;;; This program is distributed in the hope that it will be useful,
10+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
11+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12+;;;; Affero General Public License for more details.
13+;;;;
14+;;;; You should have received a copy of the GNU Affero General Public License
15+;;;; along with this program. If not, see <https://www.gnu.org/licenses/>.
16+(in-package :satou)
17+
18+(define-condition vgm-player-settings-error (satou-error)
19+ ())
20+
21+(deftype t/ym2151-core ()
22+ '(member :mame))
23+
24+(defclass vgm-player-settings ()
25+ ((sample-rate
26+ :initarg :sample-rate
27+ :initform +default-sample-rate+
28+ :type t/uint32
29+ :accessor settings-sample-rate
30+ :documentation "The target sample rate to use for playback.")
31+
32+ (dmg-boost-wave-chan
33+ :initarg :dmg-boost-wave-chan
34+ :initform t
35+ :type boolean
36+ :accessor settings-dmg-boost-wave-chan-p
37+ :documentation "When T, then the wave channel on the DMG is boosted.")
38+
39+ (ym2151-core
40+ :initarg :ym2151-core
41+ :initform :mame
42+ :type symbol
43+ :accessor settings-ym2151-core
44+ :documentation "The emulation core to use for the YM2151.")
45+
46+ (huc6280-core
47+ :initarg :huc6280-core
48+ :initform :ootake
49+ :type satou-chips:t/huc6280-core
50+ :accessor settings-huc6280-core
51+ :documentation "The emulation core to use for the HuC6280."))
52+ (:documentation "A set of settings that controls how VGM files are played back
53+by the VGM-PLAYER class."))
54+
55+(defmethod initialize-instance :after ((obj vgm-player-settings) &key &allow-other-keys)
56+ (with-slots (sample-rate dmg-boost-wave-chan ym2151-core huc6280-core)
57+ obj
58+ (unless (typep sample-rate 't/uint32) (satou-error (vgm-player-settings-error) "SAMPLE-RATE must be a T/UINT32"))
59+ (unless (typep dmg-boost-wave-chan 'boolean)
60+ (satou-error (vgm-player-settings-error) "DMG-BOOST-WAVE-CHAN must be a BOOLEAN"))
61+ (unless (typep ym2151-core 't/ym2151-core)
62+ (satou-error (vgm-player-settings-error) "YM2151-CORE must be a T/YM2151-CORE"))
63+ (unless (typep huc6280-core 'satou-chips:t/huc6280-core)
64+ (satou-error (vgm-player-settings-error) "HUC6280-CORE must be a T/HUC6280-CORE"))))
65+
66+(defmethod (setf settings-sample-rate) :before (value (object vgm-player-settings))
67+ (check-type value t/uint32))
68+
69+(defmethod (setf settings-dmg-boost-wave-chan-p) :before (value (object vgm-player-settings))
70+ (check-type value boolean))
71+
72+(defmethod (setf settings-ym2151-core) :before (value (object vgm-player-settings))
73+ (check-type value t/ym2151-core))
74+
75+(defmethod (setf settings-huc6280-core) :before (value (object vgm-player-settings))
76+ (check-type value satou-chips:t/huc6280-core))
diff -r 000000000000 -r 98c8a1775355 src/vgm-player.lisp
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/vgm-player.lisp Wed May 24 02:52:21 2023 -0600
@@ -0,0 +1,782 @@
1+;;;; SatouSynth
2+;;;; Copyright (C) 2023 Remilia Scarlet <remilia@posteo.jp>
3+;;;; Based on VGMPlay, Copyright (C) Valley Bell
4+;;;;
5+;;;; This program is free software: you can redistribute it and/or
6+;;;; modify it under the terms of the GNU Affero General Public
7+;;;; License as published by the Free Software Foundation, either
8+;;;; version 3 of the License, or (at your option) any later version.
9+;;;;
10+;;;; This program is distributed in the hope that it will be useful,
11+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13+;;;; Affero General Public License for more details.
14+;;;;
15+;;;; You should have received a copy of the GNU Affero General Public License
16+;;;; along with this program. If not, see <https://www.gnu.org/licenses/>.
17+(in-package :satou)
18+
19+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
20+;;;
21+;;; VGM Player Struct and Reader Functions
22+;;;
23+
24+(defstruct (vgm-player (:constructor %make-vgm-player)
25+ (:conc-name %player-))
26+ (settings (make-instance 'vgm-player-settings) :type vgm-player-settings)
27+ (vgm nil :type (or null vgm-file))
28+ (sample-rate +default-sample-rate+ :type t/uint32)
29+ (min-buffer-size 100 :type t/int32)
30+ (play-time 0 :type t/int32)
31+ (main-volume 1.0d0 :type double-float)
32+ (at-end-p nil :type boolean)
33+ (times-played 0 :type t/uint32)
34+ (chip-table (make-hash-table) :type hash-table)
35+ (samples-per-buffer 100 :type t/int32)
36+ (volume-modifier 1.0d0 :type double-float)
37+
38+ ;;;
39+ ;;; Playback Fields
40+ ;;;
41+
42+ (vgm-sample-played 0 :type t/int32)
43+ (vgm-sample-pos 0 :type t/int32)
44+ (vgm-playback-rate 0 :type t/uint32)
45+ (vgm-playback-rate-mul 0 :type t/uint32)
46+ (vgm-playback-rate-div 0 :type t/uint32)
47+ (vgm-sample-rate-mul 0 :type t/uint32)
48+ (vgm-sample-rate-div 0 :type t/uint32)
49+ (vgm-sample-rate +vgm-sample-rate+ :type t/uint32)
50+
51+ ;;;
52+ ;;; Additional Fields
53+ ;;;
54+
55+ (resampler nil :type (or null resampler))
56+ (output-volume 1.0d0 :type double-float)
57+ (ip 0 :type fixnum)
58+ (stream-buffers nil :type (or null t/output-buffer))
59+ (temp-buf (vector 0 0) :type simple-vector)
60+ (dac-control nil :type (or null satou/dac:dac-controller))
61+ (playing-p nil :type boolean)
62+ (chip-set-created-p nil :type boolean))
63+
64+(define-typed-fn vgm-player-settings ((vgm-player player))
65+ (vgm-player-settings t)
66+ (declare (optimize (speed 3) (debug 1) (safety 0) (compilation-speed 0)))
67+ (%player-settings player))
68+
69+(define-typed-fn vgm-player-vgm((vgm-player player))
70+ (vgm-file t)
71+ (declare (optimize (speed 3) (debug 1) (safety 0) (compilation-speed 0)))
72+ (%player-vgm player))
73+
74+(define-typed-fn vgm-player-sample-rate ((vgm-player player))
75+ (t/uint32 t)
76+ (declare (optimize (speed 3) (debug 1) (safety 0) (compilation-speed 0)))
77+ (%player-sample-rate player))
78+
79+(define-typed-fn vgm-player-min-buffer-size ((vgm-player player))
80+ (t/int32 t)
81+ (declare (optimize (speed 3) (debug 1) (safety 0) (compilation-speed 0)))
82+ (%player-min-buffer-size player))
83+
84+(define-typed-fn vgm-player-play-time ((vgm-player player))
85+ (t/int32 t)
86+ (declare (optimize (speed 3) (debug 1) (safety 0) (compilation-speed 0)))
87+ (%player-play-time player))
88+
89+(muffling
90+ (define-typed-fn vgm-player-main-volume ((vgm-player player))
91+ (double-float t)
92+ (declare (optimize (speed 3) (debug 1) (safety 0) (compilation-speed 0)))
93+ (%player-main-volume player)))
94+
95+(define-typed-fn vgm-player-at-end-p ((vgm-player player))
96+ (boolean t)
97+ (declare (optimize (speed 3) (debug 1) (safety 0) (compilation-speed 0)))
98+ (%player-at-end-p player))
99+
100+(define-typed-fn vgm-player-times-played ((vgm-player player))
101+ (t/uint32 t)
102+ (declare (optimize (speed 3) (debug 1) (safety 0) (compilation-speed 0)))
103+ (%player-times-played player))
104+
105+(define-typed-fn vgm-player-chip-table ((vgm-player player))
106+ (hash-table t)
107+ (declare (optimize (speed 3) (debug 1) (safety 0) (compilation-speed 0)))
108+ (%player-chip-table player))
109+
110+(define-typed-fn vgm-player-samples-per-buffer ((vgm-player player))
111+ (t/int32 t)
112+ (declare (optimize (speed 3) (debug 1) (safety 0) (compilation-speed 0)))
113+ (%player-samples-per-buffer player))
114+
115+(muffling
116+ (define-typed-fn vgm-player-volume-modifier ((vgm-player player))
117+ (double-float t)
118+ (declare (optimize (speed 3) (debug 1) (safety 0) (compilation-speed 0)))
119+ (%player-volume-modifier player)))
120+
121+(define-typed-fn vgm-player-playing-p ((vgm-player player))
122+ (boolean t)
123+ (declare (optimize (speed 3) (debug 1) (safety 0) (compilation-speed 0)))
124+ (%player-playing-p player))
125+
126+(defmethod print-object ((player vgm-player) out)
127+ (print-unreadable-object (player out :type t)
128+ (format out "Sample Rate: ~a, Playing: ~:[no~;yes~], Timed Played: ~:d"
129+ (vgm-player-sample-rate player)
130+ (vgm-player-playing-p player)
131+ (vgm-player-times-played player))))
132+
133+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
134+;;;
135+;;; Internal VGM Player Utility Functions
136+;;;
137+
138+(define-typed-fn %player-get-data-byte ((vgm-player player) (fixnum idx))
139+ (t/uint8 t)
140+ "Returns the data byte at IDX in the data stream."
141+ (declare (optimize (speed 3) (debug 0) (safety 0) (compilation-speed 0)))
142+ (aref (the t/uint8-array (vgm-file-data (%player-vgm player))) idx))
143+
144+(define-typed-fn %player-get-chip-number ((vgm-player player))
145+ (t/uint8 t)
146+ "Gets the chip number from the data stream."
147+ (declare (optimize (speed 3) (debug 0) (safety 0) (compilation-speed 0)))
148+ (ash (logand (%player-get-data-byte player (1+ (%player-ip player))) #x80) -7))
149+
150+(define-typed-fn %player-get-int16-le ((vgm-player player) (fixnum at))
151+ (fixnum t)
152+ "Gets a little-endian signed 16-bit integer from the data stream."
153+ (declare (optimize (speed 3) (debug 0) (safety 0) (compilation-speed 0)))
154+ (logior (ash (%player-get-data-byte player (1+ at)) 8)
155+ (%player-get-data-byte player at)))
156+
157+(define-typed-fn %player-get-int16-be ((vgm-player player) (fixnum at))
158+ (fixnum t)
159+ "Gets a big-endian signed 16-bit integer from the data stream."
160+ (declare (optimize (speed 3) (debug 0) (safety 0) (compilation-speed 0)))
161+ (logior (%player-get-data-byte player at)
162+ (ash (%player-get-data-byte player (1+ at)) 8)))
163+
164+(define-typed-fn %player-get-int32-le ((vgm-player player) (fixnum at))
165+ (fixnum t)
166+ "Gets a little-endian signed 32-bit integer from the data stream."
167+ (declare (optimize (speed 3) (debug 0) (safety 0) (compilation-speed 0)))
168+ (coerce-to-int32
169+ (logior (ash (%player-get-data-byte player (+ at 3)) 24)
170+ (ash (%player-get-data-byte player (+ at 2)) 16)
171+ (ash (%player-get-data-byte player (+ at 1)) 8)
172+ (%player-get-data-byte player at))))
173+
174+(define-typed-fn %player-pcm-sample->vgm-sample ((vgm-player player) (t/int64 sample-num))
175+ (t/uint32 t)
176+ (declare (optimize (speed 3) (debug 1) (safety 0) (compilation-speed 0)))
177+ (pcm-sample->vgm-sample sample-num (%player-vgm-sample-rate-div player) (%player-vgm-sample-rate-mul player)))
178+
179+(define-typed-fn %player-vgm-sample->pcm-sample ((vgm-player player) (t/int64 sample-num))
180+ (t/uint32 t)
181+ (declare (optimize (speed 3) (debug 1) (safety 0) (compilation-speed 0)))
182+ (vgm-sample->pcm-sample sample-num (%player-vgm-sample-rate-div player) (%player-vgm-sample-rate-mul player)))
183+
184+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
185+;;;
186+;;; VGM Player Instructions
187+;;;
188+;;; Each instruction returns the number of instructions that the player should
189+;;; advance after calling these functions.
190+;;;
191+
192+(defmacro define-player-instruction (name (player-argument ip-var) &body forms)
193+ `(define-typed-fn ,name ((vgm-player ,player-argument))
194+ (fixnum t)
195+ (declare (optimize (speed 3) (debug 0) (safety 0) (compilation-speed 0)))
196+ (let ((,ip-var (%player-ip ,player-argument)))
197+ ,@forms)))
198+
199+(define-player-instruction %player-huc6280-write (player ip)
200+ (let* ((cur-chip (%player-get-chip-number player))
201+ (chip (muffling (aref (the (vector abstract-chip) (gethash :huc6280 (%player-chip-table player))) cur-chip))))
202+ (chip-write chip
203+ (logand (%player-get-data-byte player (+ ip 1)) #x7F)
204+ (%player-get-data-byte player (+ ip 2)))
205+ 3))
206+
207+(define-player-instruction %player-c352-write (player ip)
208+ (let* ((cur-chip (%player-get-chip-number player))
209+ (chip (muffling (aref (the (vector abstract-chip) (gethash :c352 (%player-chip-table player))) cur-chip)))
210+ (address (coerce-to-uint32
211+ (logior (ash (logand (%player-get-data-byte player (+ ip 1)) #x7F) 8)
212+ (%player-get-data-byte player (+ ip 2))))))
213+ (chip-write chip
214+ address
215+ (coerce-to-uint16
216+ (logior (ash (%player-get-data-byte player (+ ip 3)) 8)
217+ (%player-get-data-byte player (+ ip 4)))))
218+ 5))
219+
220+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
221+;;;
222+;;; VGM Player PCM Instructions
223+;;;
224+;;; Each instruction returns the number of instructions that the player should
225+;;; advance after calling these functions.
226+;;;
227+
228+(define-typed-fn %player-load-pcm-stream ((vgm-player player))
229+ (t/int32)
230+ (declare (optimize (speed 1) (debug 3) (safety 1) (compilation-speed 0)))
231+ (let* ((ip (%player-ip player))
232+ (temp-byte (%player-get-data-byte player (+ ip 2)))
233+ (temp-long (%player-get-int32-le player (+ ip 3)))
234+ (cur-chip 0))
235+ (declare (t/uint8 temp-byte)
236+ (t/int32 temp-long)
237+ (type fixnum cur-chip))
238+
239+ (when (flag? temp-long #x80000000)
240+ (logandf temp-long #x7FFFFFFF)
241+ (setf cur-chip 1))
242+
243+ (with-typed-slots ((t/uint8-array data))
244+ (%player-vgm player)
245+
246+ ;; Determine how to load the data
247+ (case (logand temp-byte #xC0)
248+ ((#x00 #x40) ;; Database block
249+ (when (zerop (%player-times-played player))
250+ (dlog "PCM loading: Database block")
251+ (satou/dac:dac-add-pcm-data (%player-dac-control player)
252+ temp-byte
253+ (coerce-to-uint32 temp-long)
254+ (subseq data (+ ip 7)))))
255+
256+ (#x80 ;; ROM/RAM dump
257+ (dlog "PCM Loading: ROM/RAM dump")
258+
259+ (when (zerop (%player-times-played player))
260+ (let ((rom-size (%player-get-int32-le player (+ ip 7)))
261+ (data-start (%player-get-int32-le player (+ ip #x0B)))
262+ (data-len (- temp-long 8))
263+ (rom-data-pos (+ ip #x0F)))
264+ (dlog " PCM ROM size: ~a, data pos: ~a, data len: ~a, ROM pos: ~a"
265+ rom-size data-start data-len rom-data-pos)
266+
267+ ;; Write the PCM data to the correct chip
268+ (case temp-byte
269+ (#x92 ;; C352 ROM image
270+ (dlog " Loading C352 ROM image")
271+ (chip-write-rom (aref (gethash :c352 (%player-chip-table player)) cur-chip)
272+ rom-size data-start data-len (subseq data (+ ip #x0F))))
273+
274+ (otherwise
275+ (sdm-log:warn! "Unsupported PCM ROM image type: $~2,'0x" temp-byte))))))
276+
277+ (#xC0 ;; RAM write
278+ (let* ((data-start 0)
279+ (data-len 0)
280+ (rom-data nil))
281+ (setf data-start (cond
282+ ((flag? temp-byte #x20)
283+ (setf data-start (%player-get-int16-le player (+ ip #x07)))
284+ (setf data-len (- temp-long #x02))
285+ (subseq data (+ ip #x09)))
286+ (t
287+ (setf data-start (%player-get-int32-le player (+ ip #x07)))
288+ (setf data-len (- temp-long #x04))
289+ (subseq data (+ ip #x0B)))))
290+
291+ (case temp-byte
292+ (otherwise
293+ (sdm-log:warn! "Unsupported chip RAM write: $~2,'0x" temp-byte)))))))
294+ (+ 7 temp-long)))
295+
296+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
297+;;;
298+;;; More Internal VGM Player Functions
299+;;;
300+
301+(define-typed-fn %player-interpret-vgm ((vgm-player player) (t/uint32 sample-count))
302+ (null)
303+ (declare (optimize (speed 3) (debug 1) (safety 0) (compilation-speed 0)))
304+
305+ (let ((inst 0) ;; The command instruction
306+ (sample-played (%player-pcm-sample->vgm-sample player (+ (%player-vgm-sample-played player) sample-count)))
307+ (data (vgm-file-data (%player-vgm player)))
308+ (temp-byte 0)
309+ (temp-short 0)
310+ (stream-id 0)
311+ (header (vgm-file-header (%player-vgm player)))
312+
313+ ;; TODO: Most instructions calculate this themselves. A few do not.
314+ ;; This should be made consistent.
315+ (cur-chip 0))
316+ (declare (type t/uint8 inst temp-byte stream-id cur-chip)
317+ (t/uint16 temp-short)
318+ (t/uint8-array data)
319+ (t/uint32 sample-played)
320+ (vgm-file-header header)
321+
322+ (ignore stream-id temp-short temp-byte))
323+
324+ (loop while (<= (%player-vgm-sample-pos player) sample-played) do
325+ (setf inst (aref data (%player-ip player)))
326+ ;;(dlog "Next instruction: ~2,'0x" inst)
327+
328+ (cond
329+ ((and (>= inst #x70) (<= inst #x8F))
330+ (case (logand inst #xF0)
331+ (#x70
332+ (incf (%player-vgm-sample-pos player) (1+ (logand inst #x0F))))
333+
334+ (#x80
335+ ;;(setf temp-byte (satou/dac:dac-get-dac-from-pcm-bank (%player-dac-control player)))
336+ (when (/= (vgm-header-ym2612-clock header) 0)
337+ ;; TODO ym2612 stuff
338+ )
339+ (incf (%player-vgm-sample-pos player) (logand inst #x0F))))
340+ (incf (%player-ip player)))
341+
342+ (t
343+ ;; This first CASE statement may modify the instruction.
344+ (case inst
345+ (#xA4
346+ (when (flag? (vgm-header-ym2151-clock header) #x40000000)
347+ (decf inst #x50)
348+ (setf cur-chip #x01)))
349+
350+ (#xA5
351+ (when (flag? (vgm-header-ym2203-clock header) #x40000000)
352+ (decf inst #x50)
353+ (setf cur-chip #x01)))
354+
355+ ((#xA6 #xA7)
356+ (when (flag? (vgm-header-ym2608-clock header) #x40000000)
357+ (decf inst #x50)
358+ (setf cur-chip #x01)))
359+
360+ ((#xA8 #xA9)
361+ (when (flag? (vgm-header-ym2610-clock header) #x40000000)
362+ (decf inst #x50)
363+ (setf cur-chip #x01)))
364+
365+ (#xAd
366+ (when (flag? (vgm-header-ymz280b-clock header) #x40000000)
367+ (decf inst #x50)
368+ (setf cur-chip #x01))))
369+
370+ ;; The second case statement is where the commands are dispatched.
371+ (case inst
372+ ;;;
373+ ;;; Chip commands
374+ ;;;
375+ (#xB9 (incf (%player-ip player) (%player-huc6280-write player)))
376+ (#xE1 (incf (%player-ip player) (%player-c352-write player)))
377+
378+ ;;;
379+ ;;; DAC commands
380+ ;;;
381+ ;; TODO
382+
383+ ;;;
384+ ;;; Other Commands
385+ ;;;
386+
387+ ;; TODO
388+ (#x67 (incf (%player-ip player) (%player-load-pcm-stream player)))
389+
390+ (#x61 ;; Delay sample by X amount
391+ (incf (%player-vgm-sample-pos player) (%player-get-int16-le player (1+ (%player-ip player))))
392+ (incf (%player-ip player) 3))
393+
394+ (#x62 ;; Delay sample by 1/60s
395+ (incf (%player-vgm-sample-pos player) 735)
396+ (incf (%player-ip player)))
397+
398+ (#x63 ;; Delay sample by 1/50s
399+ (incf (%player-vgm-sample-pos player) 882)
400+ (incf (%player-ip player)))
401+
402+ (#x66 ;; End of VGM
403+ (incf (%player-times-played player))
404+
405+ (cond
406+ ((/= (the t/uint32 (vgm-header-loop-offset header)) 0)
407+ ;; We have loop data, so do the loop.
408+ (with-typed-slots ((t/uint32 loop-offset data-offset loop-samples))
409+ header
410+ (setf (%player-ip player)
411+ (coerce-to-int32 (- (+ loop-offset +loop-offset-offset+) data-offset)))
412+
413+ (cond
414+ ;; Ensure we're within bounds
415+ ((and (>= (%player-ip player) 0) (< (%player-ip player) (length data)))
416+ (decf (%player-vgm-sample-pos player) (coerce-to-int32 loop-samples))
417+ (decf (%player-vgm-sample-played player) (%player-vgm-sample->pcm-sample player loop-samples))
418+ (setf sample-played
419+ (%player-pcm-sample->vgm-sample player (+ (%player-vgm-sample-played player) sample-count))))
420+
421+ (t
422+ (sdm-log:warn! "Aborting playback, instruction pointer ended up at an odd place")
423+ (setf (%player-at-end-p player) t)
424+ (%player-reset-chips player)
425+ (return-from %player-interpret-vgm)))))
426+
427+ (t
428+ ;; No loop
429+ (setf (%player-at-end-p player) t)
430+ (return-from %player-interpret-vgm))))
431+
432+ (otherwise
433+ ;; Skip unimplemented, but reserved, instructions.
434+ (incf (%player-ip player)
435+ (case (logand inst #xF0)
436+ ((#x00 #x10 #x20) 1)
437+ (#x30 2)
438+ ((#x40 #x50 #xB0) 3)
439+ ((#xC0 #xD0) 4)
440+ (#xF0 5)
441+ (otherwise (satou-error () "Unknown VGM instruction: $~2,'0x at data offset $~8,'0x"
442+ inst (%player-ip player)))))))))))
443+ nil)
444+
445+(define-typed-fn %player-interpret-file ((vgm-player player) (t/uint32 sample-count))
446+ (null t)
447+ (declare (optimize (speed 3) (debug 1) (safety 0) (compilation-speed 0)))
448+ (satou/dac:dac-update (%player-dac-control player) (1- sample-count))
449+ (%player-interpret-vgm player sample-count)
450+ (satou/dac:dac-update (%player-dac-control player) 1)
451+ (incf (%player-play-time player) sample-count)
452+ (incf (%player-vgm-sample-played player) sample-count)
453+ nil)
454+
455+(defun %player-setup-resampling-for-chip (player chip low-quality?)
456+ (declare (type vgm-player player))
457+
458+ (dlog "Chip ~a sample rate: ~a, target sample rate: ~a"
459+ (type-of chip) (chip-sample-rate chip) (%player-sample-rate player))
460+ (cond
461+ (low-quality?
462+ (setf (chip-resampler-type chip) :old)
463+ (dlog " Old resampler mode forced"))
464+
465+ (t
466+ (setf (chip-resampler-type chip)
467+ (cond
468+ ((< (chip-sample-rate chip) (%player-sample-rate player)) :upsampling)
469+ ((> (chip-sample-rate chip) (%player-sample-rate player)) :downsampling)
470+ (t :copy)))
471+ (dlog " Resample mode: ~a" (chip-resampler-type chip))))
472+
473+ (with-slots (cur-sample-num next-sample-num last-sample-num next-sample last-sample)
474+ chip
475+ (setf cur-sample-num 0)
476+ (setf next-sample-num 0)
477+ (setf last-sample-num 0)
478+ (setf last-sample (vector 0 0))
479+
480+ (case (chip-resampler-type chip)
481+ (:upsampling
482+ ;; Pre-generate the first sample
483+ (chip-update chip (%player-stream-buffers player) 1)
484+ (setf (sample-left next-sample) (aref (svref (%player-stream-buffers player) 0) 0))
485+ (setf (sample-right next-sample) (aref (svref (%player-stream-buffers player) 1) 0)))
486+
487+ (otherwise
488+ (setf (sample-left next-sample) 0)
489+ (setf (sample-right next-sample) 0))))
490+ nil)
491+
492+(defun %player-setup-resampling (player &optional low-quality?)
493+ (declare (type vgm-player player))
494+ (setf (%player-resampler player) (make-resampler :sample-rate (%player-sample-rate player)
495+ :stream-buffers (%player-stream-buffers player)))
496+
497+ (with-each-chip (chip (%player-chip-table player))
498+ (%player-setup-resampling-for-chip player chip low-quality?)
499+
500+ ;; Setup resampling for its paired chip as well.
501+ (when (chip-is-paired-p chip)
502+ (%player-setup-resampling-for-chip player (slot-value chip 'paired) low-quality?)))
503+ nil)
504+
505+(define-typed-fn %player-clamp-int32-to-int16 ((t/int32 value))
506+ (t/int16 t)
507+ (declare (optimize (speed 3) (debug 0) (safety 0) (compilation-speed 0)))
508+ (clamp value -32768 32767))
509+
510+(defun (setf vgm-player-main-volume) (value player)
511+ (declare (optimize (speed 3) (debug 1) (safety 0) (compilation-speed 0)))
512+ (check-type value double-float)
513+ (check-type player vgm-player)
514+ (setf (%player-main-volume player) value)
515+ (setf (%player-output-volume player) (+ (* 256.0d0 (* (%player-main-volume player)
516+ (%player-volume-modifier player)))
517+ 0.5d0))
518+ value)
519+
520+(define-typed-fn %player-fill-buffers ((vgm-player player) (t/int16-vector left right))
521+ (null)
522+ (declare (optimize (speed 3) (debug 1) (compilation-speed 0)
523+ #+satou-wd40 (safety 0)
524+ #-satou-wd40 (safety 1)))
525+
526+ (let ((cur-volume (truncate (%player-output-volume player)))
527+ (buf (%player-temp-buf player)))
528+ (declare (type fixnum cur-volume))
529+
530+ #-satou-wd40 (unless (= (length left) (length right))
531+ (error "Buffer size mismatch"))
532+
533+ (loop with len fixnum = (length left)
534+ for sample-num fixnum from 0 below len
535+ do ;; Generate and resample the new sample.
536+ (%player-interpret-file player 1)
537+ (resampler-resample (%player-resampler player) (%player-chip-table player) buf 1)
538+
539+ ;; Adjust the volume.
540+ (setf (sample-left buf) (ash (coerce-to-int32 (* (ash (sample-left buf) -5) cur-volume)) -11))
541+ (setf (sample-right buf) (ash (coerce-to-int32 (* (ash (sample-right buf) -5) cur-volume)) -11))
542+
543+ ;; Store the new sample
544+ (muffling
545+ (setf (aref left sample-num) (%player-clamp-int32-to-int16 (sample-left buf)))
546+ (setf (aref right sample-num) (%player-clamp-int32-to-int16 (sample-right buf))))))
547+ nil)
548+
549+(define-typed-fn %player-reset-chips ((vgm-player player))
550+ (null)
551+ (with-each-chip (chip (%player-chip-table player))
552+ (chip-reset chip)
553+
554+ (when (chip-is-paired-p chip)
555+ (chip-reset (slot-value chip 'paired))))
556+ nil)
557+
558+(define-typed-fn %player-start-chip ((vgm-player player) (abstract-chip chip))
559+ (t/uint32)
560+ (declare (optimize (speed 3) (debug 1) (safety 0) (compilation-speed 0)))
561+ (let ((start-flags (chip-start-flags chip (%player-vgm player))))
562+ ;; TODO
563+ ;;(when (typep chip 'dmg)
564+ ;; (if (settings-dmg-boost-wave-chan-p (%player-settings player))
565+ ;; (setf (dmg-start-flags-value start-flags) 3)
566+ ;; (setf (dmg-start-flags-value start-flags) 0)))
567+
568+ (chip-start chip (chip-clock chip) start-flags)
569+ (the t/uint32 (chip-volume-modifier chip))))
570+
571+(define-typed-fn %player-start-all-chips ((vgm-player player))
572+ (null)
573+ "Starts all allocated chips."
574+
575+ ;; Remi: This is some weird hacky stuff.
576+ (let ((vol-mod 0))
577+ ;; Start each chip. Also collect the volume modification value so that we
578+ ;; can ensure a proper output level for the given set of chips.
579+ (with-each-chip (chip (%player-chip-table player))
580+ (incf vol-mod (%player-start-chip player chip)))
581+
582+ ;; Reset the chips, then adjust their output volumes.
583+ (%player-reset-chips player)
584+ (loop while (and (< vol-mod #x200) (/= vol-mod 0)) do
585+ (with-each-chip (chip (%player-chip-table player))
586+ (setf (chip-volume chip) (* (chip-volume chip) 2)))
587+ (setf vol-mod (* vol-mod 2)))
588+
589+ (loop while (> vol-mod #x300) do
590+ (with-each-chip (chip (%player-chip-table player))
591+ (setf (chip-volume chip) (truncate (chip-volume chip) 2)))
592+ (setf vol-mod (truncate vol-mod 2))))
593+ nil)
594+
595+(define-typed-fn %player-setup-chip-set ((vgm-player player))
596+ (null)
597+ ;; May have been created with VGM-PLAYER-GET-CHIP-NAMES VGM-PLAYER-CHIPS-USED
598+ (unless (%player-chip-set-created-p player)
599+ (maphash #'(lambda (chip-type count)
600+ (loop repeat count
601+ for chip = (make-chip-instance chip-type
602+ (%player-vgm player) (%player-sample-rate player) 0
603+ (%player-sample-rate player) (%player-settings player))
604+ when chip do
605+ (unless (hash-table-contains-p (%player-chip-table player) chip-type)
606+ (setf (gethash chip-type (%player-chip-table player)) (new-vector 'abstract-chip)))
607+ (vector-push-extend chip (gethash chip-type (%player-chip-table player)))))
608+ (vgm-file-chips-used (%player-vgm player)))
609+
610+ (setf (satou/dac:dac-chip-table (%player-dac-control player)) (%player-chip-table player))
611+ (setf (%player-chip-set-created-p player) t))
612+ nil)
613+
614+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
615+;;;
616+;;; Public VGM Player Functions
617+;;;
618+
619+(defun make-vgm-player (vgm &optional settings)
620+ "Creates a new VGM-PLAYER instance that will play the given VGM file."
621+ (check-type vgm vgm-file)
622+ (check-type settings (or null vgm-player-settings))
623+
624+ (let* (;; Create the default settings if none were passed in.
625+ (settings (or settings (make-instance 'vgm-player-settings)))
626+
627+ ;; Get a handle on the header for less typing.
628+ (header (vgm-file-header vgm))
629+
630+ ;; This is used to adjust chip output volume. It is a per-VGM setting
631+ ;; that VGM authors can use to adjust the volumes of their VGM files.
632+ (vol-mod-base (cond
633+ ((<= (vgm-header-volume-modifier header) +volume-modifier-wrap+)
634+ (coerce-to-int32 (vgm-header-volume-modifier header)))
635+ ((= (vgm-header-volume-modifier header) (1+ +volume-modifier-wrap+))
636+ (- +volume-modifier-wrap+ #x100))
637+ (t
638+ (- (vgm-header-volume-modifier header) #x100))))
639+
640+ ;; Base for the internal buffer sizes.
641+ (min-buffer-size (coerce-to-int32 (truncate (settings-sample-rate settings) (* 100 2))))
642+
643+ ;; Create the VGM-PLAYER. We still need to call (SETF
644+ ;; VGM-PLAYER-MAIN-VOLUME) since it does a few extra calculations.
645+ (ret (%make-vgm-player :vgm vgm
646+ :settings settings
647+ :sample-rate (settings-sample-rate settings)
648+ :min-buffer-size min-buffer-size
649+ :samples-per-buffer (truncate min-buffer-size 2)
650+ :stream-buffers (vector (new-array 100 t/int32) (new-array 100 t/int32))
651+ :dac-control (satou/dac:make-dac-controller (settings-sample-rate settings))
652+ :volume-modifier (expt 2.0d0 (/ vol-mod-base #x20)))))
653+ (setf (vgm-player-main-volume ret) 1.0d0)
654+ ret))
655+
656+(defun calc-resampling-values* (sample-rate vgm &key (playback-rate 0) (vgm-sample-rate +vgm-sample-rate+))
657+ (declare (optimize (speed 3) (debug 1) (safety 1) (compilation-speed 0)))
658+ (check-type sample-rate t/uint32)
659+ (check-type vgm vgm-file)
660+ (check-type playback-rate t/uint32)
661+ (check-type vgm-sample-rate t/uint32)
662+
663+ (with-typed-slots ((vgm-file-header header))
664+ vgm
665+ (with-typed-slots ((t/uint32 rate))
666+ header
667+ (let ((rate-mul 0)
668+ (rate-div 0)
669+ (playback-rate-mul 0)
670+ (playback-rate-div 0))
671+ (declare (type t/uint32 rate-mul rate-div playback-rate-mul playback-rate-div))
672+
673+ (cond
674+ ((or (zerop playback-rate) (zerop rate))
675+ (setf playback-rate-mul 1)
676+ (setf playback-rate-div 1))
677+ (t
678+ (let ((val (muffling (gcd rate playback-rate))))
679+ (setf playback-rate-mul (coerce-to-uint32 (truncate rate val)))
680+ (setf playback-rate-div (coerce-to-uint32 (truncate playback-rate val))))))
681+
682+ (setf rate-mul (coerce-to-uint32 (* sample-rate playback-rate-mul)))
683+ (setf rate-div (coerce-to-uint32 (* vgm-sample-rate playback-rate-div)))
684+
685+ (let ((val (muffling (gcd rate-mul rate-div))))
686+ (setf rate-mul (coerce-to-uint32 (truncate rate-mul val)))
687+ (setf rate-div (coerce-to-uint32 (truncate rate-div val))))
688+
689+ (values rate-mul rate-div playback-rate-mul playback-rate-div)))))
690+
691+(define-typed-fn vgm-player-reset ((vgm-player player))
692+ (null)
693+ (setf (%player-ip player) 0)
694+ (setf (%player-vgm-sample-played player) 0)
695+ (setf (%player-vgm-sample-pos player) 0)
696+
697+ (dlog "Sample rate: ~a" (%player-sample-rate player))
698+ (dlog "VGM Header Rate: ~a" (vgm-header-rate (vgm-file-header (%player-vgm player))))
699+
700+ (multiple-value-bind (rate-mul rate-div playback-mul playback-div)
701+ (calc-resampling-values* (%player-sample-rate player) (%player-vgm player)
702+ :playback-rate (%player-vgm-playback-rate player)
703+ :vgm-sample-rate (%player-vgm-sample-rate player))
704+ (setf (%player-vgm-sample-rate-mul player) rate-mul)
705+ (setf (%player-vgm-sample-rate-div player) rate-div)
706+ (setf (%player-vgm-playback-rate-mul player) playback-mul)
707+ (setf (%player-vgm-playback-rate-div player) playback-div)
708+
709+ (dlog "VGM Playback Rate: ~a" (%player-vgm-playback-rate player))
710+ (dlog "VGM Header Rate: ~a" (vgm-header-rate (vgm-file-header (%player-vgm player))))
711+ (dlog "VGM Playback Rate Mul: ~a" (%player-vgm-playback-rate-mul player))
712+ (dlog "VGM Playback Rate Div: ~a" (%player-vgm-playback-rate-div player))
713+ (dlog "VGM Sample Rate: ~a" (%player-vgm-sample-rate player))
714+ (dlog "VGM Sample Rate Mul: ~a" (%player-vgm-sample-rate-mul player))
715+ (dlog "VGM Sample Rate Div: ~a" (%player-vgm-sample-rate-div player)))
716+ nil)
717+
718+(define-typed-fn calc-resampling-values ((t/uint32 sample-rate) (vgm-file vgm))
719+ ((values t/uint32 t/uint32) t)
720+ (declare (optimize (speed 3) (debug 1) (safety 0) (compilation-speed 0)))
721+ (multiple-value-bind (rate-mul rate-div)
722+ (calc-resampling-values* sample-rate vgm)
723+ (values rate-mul rate-div)))
724+
725+(define-typed-fn vgm-player-play ((vgm-player player) &optional low-quality-resampling?)
726+ (null)
727+ (unless (%player-playing-p player)
728+ (%player-setup-chip-set player)
729+ (%player-start-all-chips player)
730+ (vgm-player-reset player)
731+ (%player-setup-resampling player low-quality-resampling?)
732+ (setf (%player-playing-p player)t)
733+ nil))
734+
735+(define-typed-fn vgm-player-render ((vgm-player player) (t/int16-vector left right))
736+ (null t)
737+ (declare (optimize (speed 3) (debug 1) (safety 0) (compilation-speed 0)))
738+ (%player-fill-buffers player left right))
739+
740+(define-typed-fn vgm-player-stop ((vgm-player player))
741+ (null t)
742+ (setf (%player-at-end-p player) t)
743+ nil)
744+
745+(define-typed-fn vgm-player-get-chip-names ((vgm-player player) &optional use-short)
746+ (list)
747+ (declare (optimize (speed 3) (debug 1) (safety 1) (compilation-speed 0)))
748+
749+ (%player-setup-chip-set player)
750+ (let ((recorded (make-hash-table)))
751+ (maphash #'(lambda (ct chips)
752+ (declare (type (vector abstract-chip) chips)
753+ (type t/chip ct))
754+ (when (and (not (hash-table-contains-p recorded ct)) (> (length chips) 0))
755+ (let ((name (muffling (if use-short
756+ (chip-short-name (elt chips 0))
757+ (chip-name (elt chips 0))))))
758+ (if (= (length chips) 1)
759+ (setf (gethash ct recorded) name)
760+ (setf (gethash ct recorded) (format nil "~dx ~a" (length chips) name))))))
761+ (%player-chip-table player))
762+
763+ (loop for value being the hash-values in recorded
764+ collect value)))
765+
766+(define-typed-fn vgm-player-chips-used ((vgm-player player))
767+ (list)
768+ (declare (optimize (speed 3) (debug 1) (safety 1) (compilation-speed 0)))
769+
770+ (%player-setup-chip-set player)
771+ (let ((ret (make-hash-table)))
772+ (maphash #'(lambda (ct chips)
773+ (declare (type (vector abstract-chip) chips)
774+ (type t/chip ct))
775+ (if (and (not (hash-table-contains-p ret ct)) (> (length chips) 0))
776+ (setf (gethash ct ret) (length chips))
777+ (incf (the fixnum (gethash ct ret)) (length chips))))
778+ (%player-chip-table player))
779+
780+ (loop for ct being the hash-keys in ret
781+ using (hash-value count)
782+ collect (cons ct count))))
diff -r 000000000000 -r 98c8a1775355 src/vgmfile.lisp
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/src/vgmfile.lisp Wed May 24 02:52:21 2023 -0600
@@ -0,0 +1,1201 @@
1+;;;; SatouSynth
2+;;;; Copyright (C) 2023 Remilia Scarlet <remilia@posteo.jp>
3+;;;;
4+;;;; This program is free software: you can redistribute it and/or
5+;;;; modify it under the terms of the GNU Affero General Public
6+;;;; License as published by the Free Software Foundation, either
7+;;;; version 3 of the License, or (at your option) any later version.
8+;;;;
9+;;;; This program is distributed in the hope that it will be useful,
10+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
11+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12+;;;; Affero General Public License for more details.
13+;;;;
14+;;;; You should have received a copy of the GNU Affero General Public License
15+;;;; along with this program. If not, see <https://www.gnu.org/licenses/>.
16+(in-package :satou)
17+
18+;;;;
19+;;;; VGM File Handling
20+;;;;
21+
22+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
23+;;;
24+;;; Constants, Conditions, and Types
25+;;;
26+
27+(defining-consts
28+ (+vgm-magic+ "Vgm " :documentation "The magic bytes at the start of a VGM file.")
29+ (+loop-offset-offset+ #x1C))
30+
31+(define-condition vgm-error (satou-error)
32+ ())
33+
34+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
35+;;;
36+;;; Metaclass Stuff
37+;;;
38+
39+(defclass vgm-file-metaclass (closer-mop:standard-class)
40+ ())
41+
42+(defclass vgm-file-metaclass-slot (closer-mop:standard-direct-slot-definition)
43+ ((ignore?
44+ :initarg :ignore
45+ :initform nil
46+ :type boolean
47+ :reader %vgm-field-ignore-p)
48+
49+ (since
50+ :initarg :since
51+ :initform 0
52+ :type fixnum
53+ :reader %vgm-field-since)
54+
55+ (offset
56+ :initarg :offset
57+ :initform 0
58+ :type fixnum
59+ :reader %vgm-field-offset)
60+
61+ (chip-type
62+ :initarg :chip-type
63+ :initform :unknown
64+ :type keyword
65+ :reader %vgm-field-chip-type)))
66+
67+(defclass vgm-file-metaclass-slot/effective (closer-mop:standard-effective-slot-definition)
68+ ((ignore?
69+ :initarg :ignore
70+ :initform nil
71+ :type boolean
72+ :accessor %vgm-field-ignore-p)
73+
74+ (since
75+ :initarg :since
76+ :initform 0
77+ :type fixnum
78+ :accessor %vgm-field-since)
79+
80+ (offset
81+ :initarg :offset
82+ :initform 0
83+ :type fixnum
84+ :accessor %vgm-field-offset)
85+
86+ (chip-type
87+ :initarg :chip-type
88+ :initform :unknown
89+ :type keyword
90+ :accessor %vgm-field-chip-type)))
91+
92+(defmethod closer-mop:validate-superclass ((class vgm-file-metaclass) (superclass standard-class))
93+ t)
94+
95+(defmethod closer-mop:direct-slot-definition-class ((class vgm-file-metaclass) &rest initargs)
96+ (declare (ignore initargs))
97+ (find-class 'vgm-file-metaclass-slot))
98+
99+(defmethod closer-mop:effective-slot-definition-class ((class vgm-file-metaclass) &rest initargs)
100+ (declare (ignore initargs))
101+ (find-class 'vgm-file-metaclass-slot/effective))
102+
103+(defmethod closer-mop:compute-effective-slot-definition ((class vgm-file-metaclass) name direct-slots)
104+ (let ((slot-def (call-next-method)))
105+ (loop for slot in direct-slots
106+ for ignore = (%vgm-field-ignore-p slot)
107+ for since = (%vgm-field-since slot)
108+ for offset = (%vgm-field-offset slot)
109+ for chip-type = (%vgm-field-chip-type slot)
110+ do (setf
111+ (%vgm-field-ignore-p slot-def) ignore
112+ (%vgm-field-since slot-def) since
113+ (%vgm-field-offset slot-def) offset
114+ (%vgm-field-chip-type slot-def) chip-type)
115+ (loop-finish))
116+ slot-def))
117+
118+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
119+;;;
120+;;; VGM-FILE Classes and Methods
121+;;;
122+
123+(defgeneric valid-vgm-p (source)
124+ (:documentation "Checks to see if SOURCE is a valid VGM file. SOURCE may be a
125+STRING containing a path, a PATHNAME, or an open stream. If it's a stream, it
126+must be able to seek."))
127+
128+(defgeneric read-vgm-file (source &optional hint)
129+ (:documentation "Creates a new VGM-FILE instance by reading from the given
130+source. SOURCE can be a PATHNAME, a STRING containing a path, or an open
131+stream. The data in the source may be compressed.
132+
133+HINT can be a keyword which will be passed to
134+SATOU/DECOMPRESSION:MAYBE-DECOMPRESS."))
135+
136+(defclass extra-header-clock ()
137+ ((chip-id
138+ :initarg :chip-id
139+ :initform 0
140+ :type t/uint8
141+ :reader extra-header-clock-chip-id)
142+
143+ (value
144+ :initarg :value
145+ :initform 0
146+ :type t/uint32
147+ :reader extra-header-clock-value)))
148+
149+(defmethod initialize-instance :after ((obj extra-header-clock) &key &allow-other-keys)
150+ (check-type (slot-value obj 'chip-id) t/uint8)
151+ (check-type (slot-value obj 'value) t/uint32))
152+
153+(defclass extra-header-volume ()
154+ ((chip-id
155+ :initarg :chip-id
156+ :initform 0
157+ :type t/uint8
158+ :reader extra-header-volume-chip-id)
159+
160+ (flags
161+ :initarg :flags
162+ :initform 0
163+ :type t/uint8
164+ :reader extra-header-volume-flags)
165+
166+ (value
167+ :initarg :value
168+ :initform 0
169+ :type t/uint16
170+ :reader extra-header-volume-value)))
171+
172+(defmethod initialize-instance :after ((obj extra-header-volume) &key &allow-other-keys)
173+ (check-type (slot-value obj 'chip-id) t/uint8)
174+ (check-type (slot-value obj 'flags) t/uint8)
175+ (check-type (slot-value obj 'value) t/uint16))
176+
177+(defclass extra-header ()
178+ ((clocks
179+ :initform (make-hash-table)
180+ :type hash-table
181+ :reader extra-header-clocks)
182+
183+ (volumes
184+ :initform (make-hash-table)
185+ :type hash-table
186+ :reader extra-header-volumes)))
187+
188+(defclass vgm-file-header ()
189+ ((relative-eof
190+ :initform 0
191+ :type t/uint32
192+ :ignore t)
193+
194+ (version
195+ :initform 0
196+ :type t/uint32
197+ :ignore t
198+ :reader vgm-header-version
199+ :documentation "The VGM specification version this VGM file adheres to.")
200+
201+ (sn76489-clock
202+ :initform 0
203+ :type t/uint32
204+ :offset #x0C
205+ :chip-type :sn76489
206+ :reader vgm-header-sn76489-clock)
207+
208+ (ym2413-clock
209+ :initform 0
210+ :type t/uint32
211+ :offset #x10
212+ :chip-type :ym2413
213+ :reader vgm-header-ym2413-clock)
214+
215+ (gd3-offset
216+ :initform 0
217+ :type t/uint32
218+ :offset #x14
219+ :reader vgm-header-gd3-offset)
220+
221+ (total-samples
222+ :initform 0
223+ :type t/uint32
224+ :offset #x18
225+ :reader vgm-header-total-samples)
226+
227+ (loop-offset
228+ :initform 0
229+ :type t/uint32
230+ :offset #x1C
231+ :reader vgm-header-loop-offset)
232+
233+ (loop-samples
234+ :initform 0
235+ :type t/uint32
236+ :offset #x20
237+ :reader vgm-header-loop-samples)
238+
239+
240+
241+ (rate
242+ :initform 0
243+ :type t/uint32
244+ :offset #x24
245+ :since #x00000101
246+ :reader vgm-header-rate)
247+
248+
249+
250+ (sn76489-feedback
251+ :initform 0
252+ :type t/uint16
253+ :offset #x28
254+ :since #x00000110
255+ :chip-type :sn76489
256+ :reader vgm-header-sn76489-feedback)
257+
258+ (sn76489-shift-register-width
259+ :initform 0
260+ :type t/uint8
261+ :offset #x2A
262+ :since #x00000110
263+ :chip-type :sn76489
264+ :reader vgm-header-sn76489-shift-register-width)
265+
266+ (sn76489-flags
267+ :initform 0
268+ :type t/uint8
269+ :offset #x2B
270+ :since #x00000151
271+ :chip-type :sn76489
272+ :reader vgm-header-sn76489-flags)
273+
274+ (ym2612-clock
275+ :initform 0
276+ :type t/uint32
277+ :offset #x2C
278+ :since #x00000110
279+ :chip-type :ym2612
280+ :reader vgm-header-ym2612-clock)
281+
282+ (ym2151-clock
283+ :initform 0
284+ :type t/uint32
285+ :offset #x2C
286+ :since #x00000110
287+ :chip-type :ym2151
288+ :reader vgm-header-ym2151-clock)
289+
290+
291+
292+ (data-offset
293+ :initform 0
294+ :type t/uint32
295+ :offset #x34
296+ :since #x00000150
297+ :reader vgm-header-data-offset)
298+
299+
300+
301+ (spcm-clock
302+ :initform 0
303+ :type t/uint32
304+ :since #x00000151
305+ :offset #x38
306+ :chip-type :sega-pcm
307+ :reader vgm-header-spcm-clock)
308+
309+ (spcm-interface-reg
310+ :initform 0
311+ :type t/uint32
312+ :since #x00000151
313+ :offset #x3C
314+ :chip-type :sega-pcm
315+ :reader vgm-header-spcm-interface-reg)
316+
317+ (rf5c69-clock
318+ :initform 0
319+ :type t/uint32
320+ :since #x00000151
321+ :offset #x40
322+ :chip-type :rf5c69
323+ :reader vgm-header-rf5c69-clock)
324+
325+ (ym2203-clock
326+ :initform 0
327+ :type t/uint32
328+ :since #x00000151
329+ :offset #x44
330+ :chip-type :ym2203
331+ :reader vgm-header-ym2203-clock)
332+
333+ (ym2608-clock
334+ :initform 0
335+ :type t/uint32
336+ :since #x00000151
337+ :offset #x48
338+ :chip-type :ym2608
339+ :reader vgm-header-ym2608-clock)
340+
341+ (ym2610-clock
342+ :initform 0
343+ :type t/uint32
344+ :since #x00000151
345+ :offset #x4C
346+ :chip-type :ym2610
347+ :reader vgm-header-ym2610-clock)
348+
349+ (ym3812-clock
350+ :initform 0
351+ :type t/uint32
352+ :since #x00000151
353+ :offset #x50
354+ :chip-type :ym3812
355+ :reader vgm-header-ym3812-clock)
356+
357+ (ym3526-clock
358+ :initform 0
359+ :type t/uint32
360+ :since #x00000151
361+ :offset #x54
362+ :chip-type :ym3526
363+ :reader vgm-header-ym3526-clock)
364+
365+ (y8950-clock
366+ :initform 0
367+ :type t/uint32
368+ :since #x00000151
369+ :offset #x58
370+ :chip-type :y8950
371+ :reader vgm-header-y8950-clock)
372+
373+ (ymf262-clock
374+ :initform 0
375+ :type t/uint32
376+ :since #x00000151
377+ :offset #x5C
378+ :chip-type :ymf262
379+ :reader vgm-header-ymf262-clock)
380+
381+ (ymf278b-clock
382+ :initform 0
383+ :type t/uint32
384+ :since #x00000151
385+ :offset #x60
386+ :chip-type :ymf278b
387+ :reader vgm-header-ymf278b-clock)
388+
389+ (ymf271-clock
390+ :initform 0
391+ :type t/uint32
392+ :since #x00000151
393+ :offset #x64
394+ :chip-type :ymf271
395+ :reader vgm-header-ymf271-clock)
396+
397+ (ymz280b-clock
398+ :initform 0
399+ :type t/uint32
400+ :since #x00000151
401+ :offset #x68
402+ :chip-type :ymz280b
403+ :reader vgm-header-ymz280b-clock)
404+
405+ (rf5c164-clock
406+ :initform 0
407+ :type t/uint32
408+ :since #x00000151
409+ :offset #x6C
410+ :chip-type :rf5c164
411+ :reader vgm-header-rf5c164-clock)
412+
413+ (pwm-clock
414+ :initform 0
415+ :type t/uint32
416+ :since #x00000151
417+ :offset #x70
418+ :chip-type :pwm
419+ :reader vgm-header-pwm-clock)
420+
421+
422+ (ay8910-clock
423+ :initform 0
424+ :type t/uint32
425+ :since #x00000151
426+ :offset #x74
427+ :chip-type :ay8910
428+ :reader vgm-header-ay8910-clock)
429+
430+ (ay8910-chip-type
431+ :initform 0
432+ :type t/uint8
433+ :since #x00000151
434+ :offset #x78
435+ :chip-type :ay8910
436+ :reader vgm-header-ay8910-chip-type)
437+
438+ (ay8910-flags
439+ :initform 0
440+ :type t/uint8
441+ :since #x00000151
442+ :offset #x79
443+ :chip-type :ay8910
444+ :reader vgm-header-ay8910-flags)
445+
446+ (ay-ym2203-flags
447+ :initform 0
448+ :type t/uint8
449+ :since #x00000151
450+ :offset #x7A
451+ :chip-type :ay8910
452+ :reader vgm-header-ay-ym2203-flags)
453+
454+ (ay-ym2608-flags
455+ :initform 0
456+ :type t/uint8
457+ :since #x00000151
458+ :offset #x7B
459+ :chip-type :ay8910
460+ :reader vgm-header-ay-ym2608-flags)
461+
462+
463+ (volume-modifier
464+ :initform 0
465+ :type t/uint8
466+ :since #x00000160
467+ :offset #x7C
468+ :reader vgm-header-volume-modifier)
469+
470+ (reserved2
471+ :initform 0
472+ :type t/uint8
473+ :since #x00000160
474+ :offset #x7D)
475+
476+ (loop-base
477+ :initform 0
478+ :type t/int8
479+ :since #x00000160
480+ :offset #x7E
481+ :reader vgm-header-loop-base)
482+
483+ (loop-modifier
484+ :initform 0
485+ :type t/uint8
486+ :since #x00000151
487+ :offset #x7F
488+ :reader vgm-header-loop-modifier)
489+
490+
491+ (dmg-clock
492+ :initform 0
493+ :type t/uint32
494+ :since #x00000161
495+ :offset #x80
496+ :chip-type :dmg
497+ :reader vgm-header-dmg-clock)
498+
499+ (nes-apu-clock
500+ :initform 0
501+ :type t/uint32
502+ :since #x00000161
503+ :offset #x84
504+ :chip-type :nes-apu
505+ :reader vgm-header-nes-apu-clock)
506+
507+ (multi-pcm-clock
508+ :initform 0
509+ :type t/uint32
510+ :since #x00000161
511+ :offset #x88
512+ :chip-type :multi-pcm
513+ :reader vgm-header-multi-pcm-clock)
514+
515+ (upd7759-clock
516+ :initform 0
517+ :type t/uint32
518+ :since #x00000161
519+ :offset #x8C
520+ :chip-type :upd7759
521+ :reader vgm-header-upd7759-clock)
522+
523+ (oki-m6258-clock
524+ :initform 0
525+ :type t/uint32
526+ :since #x00000161
527+ :offset #x90
528+ :chip-type :oki-m6258
529+ :reader vgm-header-oki-m6258-clock)
530+
531+ (oki-m6258-flags
532+ :initform 0
533+ :type t/uint8
534+ :since #x00000161
535+ :offset #x94
536+ :chip-type :oki-m6258
537+ :reader vgm-header-oki-m6258-flags)
538+
539+ (k054539Flags
540+ :initform 0
541+ :type t/uint8
542+ :since #x00000161
543+ :offset #x95
544+ :chip-type :k054539
545+ :reader vgm-header-k054539Flags)
546+
547+ (c140-chip-type
548+ :initform 0
549+ :type t/uint8
550+ :since #x00000161
551+ :offset #x96
552+ :chip-type :c140
553+ :reader vgm-header-c140-chip-type)
554+
555+
556+ (reserved-flags
557+ :initform 0
558+ :type t/uint8
559+ :since #x00000161
560+ :offset #x97
561+ :reader vgm-header-reserved-flags)
562+
563+
564+ (oki-m6295-clock
565+ :initform 0
566+ :type t/uint32
567+ :since #x00000161
568+ :offset #x98
569+ :chip-type :oki-m6295
570+ :reader vgm-header-oki-m6295-clock)
571+
572+ (k051649-clock
573+ :initform 0
574+ :type t/uint32
575+ :since #x00000161
576+ :offset #x9C
577+ :chip-type :k051649
578+ :reader vgm-header-k051649-clock)
579+
580+ (k054539-clock
581+ :initform 0
582+ :type t/uint32
583+ :since #x00000161
584+ :offset #xA0
585+ :chip-type :k054539
586+ :reader vgm-header-k054539-clock)
587+
588+ (huc6280-clock
589+ :initform 0
590+ :type t/uint32
591+ :since #x00000161
592+ :offset #xA4
593+ :chip-type :huc6280
594+ :reader vgm-header-huc6280-clock)
595+
596+ (c140-clock
597+ :initform 0
598+ :type t/uint32
599+ :since #x00000161
600+ :offset #xA8
601+ :chip-type :c140
602+ :reader vgm-header-c140-clock)
603+
604+ (k053260-clock
605+ :initform 0
606+ :type t/uint32
607+ :since #x00000161
608+ :offset #xAC
609+ :chip-type :k053260
610+ :reader vgm-header-k053260-clock)
611+
612+ (pokey-clock
613+ :initform 0
614+ :type t/uint32
615+ :since #x00000161
616+ :offset #xB0
617+ :chip-type :pokey
618+ :reader vgm-header-pokey-clock)
619+
620+ (qsound-clock
621+ :initform 0
622+ :type t/uint32
623+ :since #x00000161
624+ :offset #xB4
625+ :chip-type :qsound
626+ :reader vgm-header-qsound-clock)
627+
628+ (scsp-clock
629+ :initform 0
630+ :type t/uint32
631+ :since #x00000171
632+ :offset #xB8
633+ :chip-type :sega-pcm
634+ :reader vgm-header-scsp-clock)
635+
636+
637+ (extra-header-offset
638+ :initform 0
639+ :type t/uint32
640+ :since #x00000170
641+ :offset #xBC
642+ :reader vgm-header-extra-header-offset)
643+
644+ (wonderswan-clock
645+ :initform 0
646+ :type t/uint32
647+ :since #x00000171
648+ :offset #xC0
649+ :chip-type :wonderswan
650+ :reader vgm-header-wonderswan-clock)
651+
652+ (vsu-clock
653+ :initform 0
654+ :type t/uint32
655+ :since #x00000171
656+ :offset #xC4
657+ :chip-type :vsu
658+ :reader vgm-header-vsu-clock)
659+
660+ (saa1099-clock
661+ :initform 0
662+ :type t/uint32
663+ :since #x00000171
664+ :offset #xC8
665+ :chip-type :saa1099
666+ :reader vgm-header-saa1099-clock)
667+
668+ (es5503-clock
669+ :initform 0
670+ :type t/uint32
671+ :since #x00000171
672+ :offset #xCC
673+ :chip-type :es5503
674+ :reader vgm-header-es5503-clock)
675+
676+ (es5506-clock
677+ :initform 0
678+ :type t/uint32
679+ :since #x00000171
680+ :offset #xD0
681+ :chip-type :es5506
682+ :reader vgm-header-es5506-clock)
683+
684+ (es5503-num-channels
685+ :initform 0
686+ :type t/uint8
687+ :since #x00000171
688+ :offset #xD4
689+ :chip-type :es5503
690+ :reader vgm-header-es5503-num-channels)
691+
692+ (es5506-num-channels
693+ :initform 0
694+ :type t/uint8
695+ :since #x00000171
696+ :offset #xD5
697+ :chip-type :es5506
698+ :reader vgm-header-es5506-num-channels)
699+
700+ (c352-clock-div
701+ :initform 0
702+ :type t/uint8
703+ :since #x00000171
704+ :offset #xD6
705+ :chip-type :c352
706+ :reader vgm-header-c352-clock-div)
707+
708+ (reserved3
709+ :initform 0
710+ :type t/uint8
711+ :since #x00000171
712+ :offset #xD7)
713+
714+ (x1-010-clock
715+ :initform 0
716+ :type t/uint32
717+ :since #x00000171
718+ :offset #xD8
719+ :chip-type :x1-010
720+ :reader vgm-header-x1-010-clock)
721+
722+ (c352-clock
723+ :initform 0
724+ :type t/uint32
725+ :since #x00000171
726+ :offset #xDC
727+ :chip-type :c352
728+ :reader vgm-header-c352-clock)
729+
730+ (ga20-clock
731+ :initform 0
732+ :type t/uint32
733+ :since #x00000171
734+ :offset #xE0
735+ :chip-type :ga20
736+ :reader vgm-header-ga20-clock)
737+
738+ (reserved4
739+ :initform 0
740+ :type t/uint32
741+ :since #x00000171
742+ :offset #xE4))
743+ (:metaclass vgm-file-metaclass))
744+
745+(defclass vgm-file ()
746+ ((header
747+ :initarg :header
748+ :initform (make-instance 'vgm-file-header)
749+ :type vgm-file-header
750+ :reader vgm-file-header
751+ :documentation "Returns the VGM-FILE-HEADER associated with this VGM.")
752+
753+ (gd3
754+ :initform (make-instance 'gd3-tag)
755+ :type gd3-tag
756+ :reader vgm-file-gd3
757+ :documentation "Returns the GD3-TAG associated with this VGM.")
758+
759+ (data
760+ :initform (new-array 0 t/uint8)
761+ :type t/uint8-array
762+ :reader vgm-file-data
763+ :documentation "Returns the data (that is, the stream of instructions and
764+data bytes) associated with this VGM.")
765+
766+ (data-offset
767+ :initform 0
768+ :type t/uint32
769+ :reader vgm-file-data-offset)
770+
771+ (extra-header
772+ :initform nil
773+ :type (or null extra-header)
774+ :reader vgm-file-extra-header
775+ :documentation "Returns the EXTRA-HEADER associated with this VGM, if any.")
776+
777+ (known-supported-chips
778+ :initform ()
779+ :type list)
780+
781+ (known-used-chips
782+ :initform (make-hash-table)
783+ :type hash-table)))
784+
785+(defmethod initialize-instance :after ((obj vgm-file) &key &allow-other-keys)
786+ (setf (slot-value obj 'data-offset) (vgm-header-data-offset (vgm-file-header obj))))
787+
788+(defgeneric vgm-file-version (vgm))
789+
790+(defmethod vgm-file-version ((vgm vgm-file))
791+ (vgm-header-version (vgm-file-header vgm)))
792+
793+(defmethod print-object ((obj vgm-file) stream)
794+ (print-unreadable-object (obj stream :type t)
795+ (format stream "Version: ~x, Data offset: $~x"
796+ (vgm-file-version obj)
797+ (vgm-file-data-offset obj))))
798+
799+(defun %read-vgm-file-header (stream)
800+ ;; Check for the magic bytes.
801+ (unless (string= (read-string stream 4) +vgm-magic+)
802+ (satou-error (vgm-error) "Not a VGM file"))
803+
804+ (let ((ret (make-instance 'vgm-file-header))
805+ (klass (find-class 'vgm-file-header)))
806+ ;; Read the first two fields manually.
807+ (setf (slot-value ret 'relative-eof) (read-uint32 stream))
808+ (setf (slot-value ret 'version) (read-uint32 stream))
809+
810+ ;; Now read the rest of the fields. We skip any fields marked :IGNORE since
811+ ;; those are read manually (like the two fields above).
812+
813+ (loop with vgm-version = (vgm-header-version ret)
814+ for slot-def in (closer-mop:class-slots klass)
815+
816+ when (and (not (%vgm-field-ignore-p slot-def))
817+ (>= vgm-version (%vgm-field-since slot-def)))
818+ do ;; Read this field
819+ (file-position stream (%vgm-field-offset slot-def))
820+ (setf (closer-mop:slot-value-using-class klass ret slot-def)
821+ (ecase (closer-mop:slot-definition-type slot-def)
822+ (t/int8 (read-int8 stream))
823+ (t/uint8 (read-byte stream))
824+ (t/uint16 (read-uint16 stream))
825+ (t/uint32 (read-uint32 stream)))))
826+
827+ ;; Adjust the data offset. This is needed because a data offset value of
828+ ;; 0x0C must be reinterpreted as a hard offset of 0x40 according to the VGM
829+ ;; specifications. Additionally, if it isn't 0x0C, we need to account for
830+ ;; the data offset field being relative to its own position.
831+ (dlog "Pre-adjustment VGM data offset in header: ~8,'0x" (vgm-header-data-offset ret))
832+ (setf (slot-value ret 'data-offset)
833+ (case (slot-value ret 'data-offset)
834+ ((0 #x0C) #x40)
835+ (otherwise (+ (slot-value ret 'data-offset) #x34))))
836+ (dlog " Post-adjustment VGM data offset: ~8,'0x" (vgm-header-data-offset ret))
837+
838+ ;; Check Loop offset and sample count.
839+ (when (and (/= (vgm-header-loop-offset ret) 0)
840+ (= (vgm-header-loop-samples ret) 0))
841+ (sdm-log:warn! "Ignoring zero-sample loop")
842+ (setf (slot-value ret 'loop-offset) 0))
843+
844+ ret))
845+
846+(defun %read-vgm-file-extra-header-clock (stream)
847+ (let ((ret (make-instance 'extra-header-clock)))
848+ (setf (slot-value ret 'chip-id) (read-byte stream))
849+ (setf (slot-value ret 'value) (read-uint32 stream))
850+ ret))
851+
852+(defun %read-vgm-file-extra-header-volume (stream)
853+ (let ((ret (make-instance 'extra-header-volume)))
854+ (setf (slot-value ret 'chip-id) (read-byte stream))
855+ (setf (slot-value ret 'flagso) (read-byte stream))
856+ (setf (slot-value ret 'value) (read-uint32 stream))
857+ ret))
858+
859+(defun %read-vgm-file-extra-header (stream)
860+ (let ((ret (make-instance 'vgm-file-extra-header))
861+ (header-size (read-uint32 stream)))
862+ (when (= header-size 4)
863+ ;; Nothing to read, return nil.
864+ (return-from %read-vgm-file-extra-header))
865+
866+ (let* ((clock-offset-pos (file-position stream))
867+ (clock-offset (read-int32 stream))
868+ (volume-offset-pos (file-position stream))
869+ (volume-offset (read-int32 stream)))
870+
871+ ;; Read clock values
872+ (file-position stream (+ clock-offset-pos clock-offset))
873+ (loop with num-clocks fixnum = (read-byte stream)
874+ repeat num-clocks do
875+ ;; Read the clock.
876+ (let ((clock (%read-vgm-file-extra-header-clock stream)))
877+ (unless (hash-table-contains-p (extra-header-clocks ret)
878+ (extra-header-clock-chip-id clock))
879+ ;; No clock values for this chip ID yet, so start a new vector.
880+ (setf (gethash (extra-header-clock-chip-id clock) (extra-header-clocks ret))
881+ (new-vector 'extra-header-clock)))
882+
883+ ;; Store the clock.
884+ (vector-push-extend clock (gethash (extra-header-clock-chip-id clock)
885+ (extra-header-clocks ret)))))
886+
887+ ;; Read volume values
888+ (file-position stream (+ volume-offset-pos volume-offset))
889+ (loop with num-volumes fixnum = (read-byte stream)
890+ repeat num-volumes do
891+ ;; Read the volume.
892+ (let ((volume (%read-vgm-file-extra-header-volume stream)))
893+ (unless (hash-table-contains-p (extra-header-volumes ret)
894+ (extra-header-volume-chip-id volume))
895+ ;; No volume values for this chip ID yet, so start a new vector.
896+ (setf (gethash (extra-header-volume-chip-id volume) (extra-header-volumes ret))
897+ (new-vector 'extra-header-volume)))
898+
899+ ;; Store the volume.
900+ (vector-push-extend volume (gethash (extra-header-volume-chip-id volume)
901+ (extra-header-volumes ret)))))
902+
903+ ret)))
904+
905+(defmacro %get-vgm-field-offset (obj slot)
906+ `(%vgm-field-offset (find ,slot (the list (closer-mop:class-slots (class-of ,obj)))
907+ :test #'eq :key #'closer-mop:slot-definition-name)))
908+
909+(defmacro %move-to-vgm-field-offset (stream obj slot &optional (extra-offset 0))
910+ `(file-position ,stream (+ ,extra-offset (the t/uint32 (%get-vgm-field-offset ,obj ,slot)))))
911+
912+(defun make-vgm-file (stream)
913+ "Creates a new VGM-FILE instance by reading data from STREAM. This data must
914+not be compressed. STREAM must be able to seek."
915+ (declare (optimize (speed 3) (debug 1)))
916+ (let* ((start-at (file-position stream))
917+
918+ ;; This will read the file magic for us.
919+ (header (%read-vgm-file-header stream))
920+
921+ ;; The instance we'll return.
922+ (ret (make-instance 'vgm-file :header header)))
923+ (declare (type fixnum start-at))
924+
925+ (with-typed-slots ((t/uint32 data-offset))
926+ ret
927+ (with-typed-slots ((t/uint32 extra-header-offset version loop-offset relative-eof gd3-offset))
928+ header
929+
930+ ;; Check the data offset. If the header reports a data offset less than
931+ ;; 0x40, then we must reinterpret it as a hard offset of 0x40.
932+ (when (< data-offset #x40)
933+ (sdm-log:warn! "Invalid data offset: $~2,'0x" (vgm-file-data-offset ret))
934+ (setf (slot-value ret 'data-offset) #x40))
935+
936+ ;; Do we have an extra header?
937+ (when (/= extra-header-offset 0)
938+ (dlog "Reading extra header")
939+ (%move-to-vgm-field-offset stream header 'extra-header-offset extra-header-offset)
940+ (setf (slot-value ret 'extra-header) (%read-vgm-file-extra-header stream)))
941+
942+ ;; Read GD3 tag
943+ (%move-to-vgm-field-offset stream header 'gd3-offset gd3-offset)
944+ (setf (slot-value ret 'gd3) (read-gd3-tag stream))
945+
946+ ;; If the VGm data starts at an offset that is lower than #x100, all
947+ ;; overlapping header bytes have to be handled as if they were zero. So set
948+ ;; these to zero now, because they're actually part of the data.
949+ (when (< (the t/uint32 (vgm-header-data-offset header)) #x100)
950+ (%clear-unused-header-data header))
951+
952+ ;; Read the data
953+ (file-position stream (vgm-header-data-offset header))
954+ (dlog "Reading VGM data starting at $~8,'0x" (file-position stream))
955+ (flex:with-output-to-sequence (out)
956+ (loop with buf = (new-array cl-sdm:*io-buffer-size* 't/uint8)
957+ with num-written fixnum = 0
958+ for pos = (read-sequence buf stream)
959+ until (zerop pos) do
960+ (write-sequence buf out :end pos)
961+ (incf num-written pos)
962+ finally (setf (slot-value ret 'data)
963+ (muffling
964+ (make-array num-written :element-type 't/uint8
965+ :initial-contents (flex:get-output-stream-sequence out))))))
966+
967+ ;; A VGM file can, optionally, start its command data within the header
968+ ;; space itself. When it does this, the unused fields are treated as if
969+ ;; they were zero. So we need to determine where the command data
970+ ;; *actually* starts.
971+ (let ((total-size (- (the fixnum (file-position stream)) start-at)))
972+ (when (or (= relative-eof 0)
973+ (> relative-eof total-size))
974+ (sdm-log:warn! "Invalid VGM EOF offset: $~2,'0x (should be $~2,'0x)"
975+ (slot-value header 'relative-eof) total-size)
976+ (setf (slot-value header 'relative-eof) total-size)))
977+
978+ ;; Adjust loop offset
979+ (when (>= loop-offset relative-eof)
980+ (setf (slot-value header 'loop-offset) 0))
981+
982+ ;; VGMs using the VGM spec v1.0 and earlier always set this to zero.
983+ (when (< version #x101)
984+ (setf (slot-value header 'rate) 0))
985+
986+ ;; Older versions of the VGM spec use the YM2413 clock for the YM2612 and
987+ ;; YM2151.
988+ (when (< version #x110)
989+ (setf (slot-value header 'ym2612-clock) (vgm-header-ym2413-clock header))
990+ (setf (slot-value header 'ym2151-clock) (vgm-header-ym2413-clock header)))
991+
992+ ;; Older versions of the VGm spec do not have these fields.
993+ (when (< version #x150)
994+ (setf (slot-value header 'spcm-clock) 0)
995+ (setf (slot-value header 'spcm-interface-reg) 0))
996+
997+ ret))))
998+
999+(defun %clear-unused-header-data (header)
1000+ "Unsets any header value that was accidentally set. This can be caused if the
1001+data offset is < 0x100."
1002+ (declare (type vgm-file-header header))
1003+ ;; NOTE At time of writing (19 May 2023), the GA20 clock field is the last
1004+ ;; field in the header that is defined. All fields after are reserved, and so
1005+ ;; we don't worry about those.
1006+
1007+ (let ((doffset (vgm-header-data-offset header))
1008+ (klass (find-class 'vgm-file-header)))
1009+ (dlog "Clearing header fields over $~8,'0x" doffset)
1010+
1011+ (loop for slot-def in (closer-mop:class-slots klass)
1012+ when (and (not (%vgm-field-ignore-p slot-def))
1013+ (<= doffset (%vgm-field-offset slot-def)))
1014+ do ;; Clear this field
1015+ (setf (closer-mop:slot-value-using-class klass header slot-def) 0)))
1016+ t)
1017+
1018+(defmethod read-vgm-file ((source stream) &optional hint)
1019+ (let ((src (satou/decompression:maybe-decompress source hint)))
1020+ (make-vgm-file src)))
1021+
1022+(defmethod read-vgm-file ((source flex:flexi-stream) &optional hint)
1023+ (let ((src (satou/decompression:maybe-decompress source hint)))
1024+ (make-vgm-file src)))
1025+
1026+(defmethod read-vgm-file ((source pathname) &optional hint)
1027+ (let ((real-hint (or hint (satou/decompression:get-hint source))))
1028+ (with-open-file (in source :direction :input :element-type '(unsigned-byte 8)
1029+ :if-does-not-exist :error)
1030+ (read-vgm-file in real-hint))))
1031+
1032+(defmethod read-vgm-file ((source string) &optional hint)
1033+ (read-vgm-file (pathname source) hint))
1034+
1035+(define-typed-fn vgm-has-loop-info-p ((vgm-file vgm))
1036+ (boolean t)
1037+ (declare (optimize (speed 3) (compilation-speed 0)))
1038+ (/= (the t/uint32 (vgm-header-loop-offset (vgm-file-header vgm))) 0))
1039+
1040+(defmethod valid-vgm-p ((source stream))
1041+ (declare (optimize (speed 3) (debug 1) (safety 0) (compilation-speed 0)))
1042+ (handler-case
1043+ (let ((src (satou/decompression:maybe-decompress source)))
1044+ (muffling (string= (the string (read-string src 4)) +vgm-magic+)))
1045+ (error ()
1046+ (return-from valid-vgm-p nil))))
1047+
1048+(defmethod valid-vgm-p ((source flex:flexi-stream))
1049+ (declare (optimize (speed 3) (debug 1) (safety 0) (compilation-speed 0)))
1050+ (handler-case
1051+ (let ((src (satou/decompression:maybe-decompress source)))
1052+ (muffling (string= (the string (read-string src 4)) +vgm-magic+)))
1053+ (error ()
1054+ (return-from valid-vgm-p nil))))
1055+
1056+(defmethod valid-vgm-p ((source pathname))
1057+ (declare (optimize (speed 3) (debug 1) (safety 0) (compilation-speed 0)))
1058+ (with-open-file (in source :direction :input :element-type '(unsigned-byte 8)
1059+ :if-does-not-exist :error)
1060+ (valid-vgm-p in)))
1061+
1062+(defmethod valid-vgm-p ((source string))
1063+ (declare (optimize (speed 3) (debug 1) (safety 0) (compilation-speed 0)))
1064+ (valid-vgm-p (pathname source)))
1065+
1066+(define-typed-fn vgm-file-chip-used-p ((vgm-file vgm) (t/chip chip))
1067+ (boolean)
1068+ (declare (optimize (speed 3) (debug 1) (safety 0) (compilation-speed 0)))
1069+
1070+ (with-typed-slots ((vgm-file-header header))
1071+ vgm
1072+ (case chip
1073+ (:sn76489 (/= (the t/uint32 (vgm-header-sn76489-clock header)) 0))
1074+ (:ym2413 (/= (the t/uint32 (vgm-header-ym2413-clock header)) 0))
1075+ (:ym2612 (/= (the t/uint32 (vgm-header-ym2612-clock header)) 0))
1076+ (:ym2151 (/= (the t/uint32 (vgm-header-ym2151-clock header)) 0))
1077+ (:sega-pcm (/= (the t/uint32 (vgm-header-spcm-clock header)) 0))
1078+ (:rf5c69 (/= (the t/uint32 (vgm-header-rf5c69-clock header)) 0))
1079+ (:ym2203 (/= (the t/uint32 (vgm-header-ym2203-clock header)) 0))
1080+ (:ym2608 (/= (the t/uint32 (vgm-header-ym2608-clock header)) 0))
1081+ (:ym2610 (/= (the t/uint32 (vgm-header-ym2610-clock header)) 0))
1082+ (:ym3812 (/= (the t/uint32 (vgm-header-ym3812-clock header)) 0))
1083+ (:ym3526 (/= (the t/uint32 (vgm-header-ym3526-clock header)) 0))
1084+ (:y8950 (/= (the t/uint32 (vgm-header-y8950-clock header)) 0))
1085+ (:ymf262 (/= (the t/uint32 (vgm-header-ymf262-clock header)) 0))
1086+ (:ymf278b (/= (the t/uint32 (vgm-header-ymf278b-clock header)) 0))
1087+ (:ymf271 (/= (the t/uint32 (vgm-header-ymf271-clock header)) 0))
1088+ (:ymz280b (/= (the t/uint32 (vgm-header-ymz280b-clock header)) 0))
1089+ (:rf5c164 (/= (the t/uint32 (vgm-header-rf5c164-clock header)) 0))
1090+ (:pwm (/= (the t/uint32 (vgm-header-pwm-clock header)) 0))
1091+ (:ay8910 (/= (the t/uint32 (vgm-header-ay8910-clock header)) 0))
1092+ (:dmg (/= (the t/uint32 (vgm-header-dmg-clock header)) 0))
1093+ (:nes-apu (/= (the t/uint32 (vgm-header-nes-apu-clock header)) 0))
1094+ (:multi-pcm (/= (the t/uint32 (vgm-header-multi-pcm-clock header)) 0))
1095+ (:upd7759 (/= (the t/uint32 (vgm-header-upd7759-clock header)) 0))
1096+ (:oki-m6258 (/= (the t/uint32 (vgm-header-oki-m6258-clock header)) 0))
1097+ (:oki-m6295 (/= (the t/uint32 (vgm-header-oki-m6295-clock header)) 0))
1098+ (:k051649 (/= (the t/uint32 (vgm-header-k051649-clock header)) 0))
1099+ (:k054539 (/= (the t/uint32 (vgm-header-k054539-clock header)) 0))
1100+ (:huc6280 (/= (the t/uint32 (vgm-header-huc6280-clock header)) 0))
1101+ (:c140 (/= (the t/uint32 (vgm-header-c140-clock header)) 0))
1102+ (:k053260 (/= (the t/uint32 (vgm-header-k053260-clock header)) 0))
1103+ (:pokey (/= (the t/uint32 (vgm-header-pokey-clock header)) 0))
1104+ (:qsound (/= (the t/uint32 (vgm-header-qsound-clock header)) 0))
1105+ (:scsp (/= (the t/uint32 (vgm-header-scsp-clock header)) 0))
1106+ (:wonderswan (/= (the t/uint32 (vgm-header-wonderswan-clock header)) 0))
1107+ (:vsu (/= (the t/uint32 (vgm-header-vsu-clock header)) 0))
1108+ (:saa1099 (/= (the t/uint32 (vgm-header-saa1099-clock header)) 0))
1109+ (:es5503 (/= (the t/uint32 (vgm-header-es5503-clock header)) 0))
1110+ (:es5506 (/= (the t/uint32 (vgm-header-es5506-clock header)) 0))
1111+ (:c352 (/= (the t/uint32 (vgm-header-c352-clock header)) 0))
1112+ (:x1-010 (/= (the t/uint32 (vgm-header-x1-010-clock header)) 0))
1113+ (:ga20 (/= (the t/uint32 (vgm-header-ga20-clock header)) 0))
1114+ (otherwise (error "Attempted to check for the existence of an unknown chip: ~a" chip)))))
1115+
1116+(define-typed-fn vgm-file-get-chip-clock ((vgm-file vgm) (t/chip chip))
1117+ (t/uint32)
1118+ (declare (optimize (speed 3) (debug 1) (safety 0) (compilation-speed 0)))
1119+
1120+ (with-typed-slots ((vgm-file-header header))
1121+ vgm
1122+ (the t/uint32
1123+ (case chip
1124+ (:sn76489 (vgm-header-sn76489-clock header))
1125+ (:ym2413 (vgm-header-ym2413-clock header))
1126+ (:ym2612 (vgm-header-ym2612-clock header))
1127+ (:ym2151 (vgm-header-ym2151-clock header))
1128+ (:sega-pcm (vgm-header-spcm-clock header))
1129+ (:rf5c69 (vgm-header-rf5c69-clock header))
1130+ (:ym2203 (vgm-header-ym2203-clock header))
1131+ (:ym2608 (vgm-header-ym2608-clock header))
1132+ (:ym2610 (vgm-header-ym2610-clock header))
1133+ (:ym3812 (vgm-header-ym3812-clock header))
1134+ (:ym3526 (vgm-header-ym3526-clock header))
1135+ (:y8950 (vgm-header-y8950-clock header))
1136+ (:ymf262 (vgm-header-ymf262-clock header))
1137+ (:ymf278b (vgm-header-ymf278b-clock header))
1138+ (:ymf271 (vgm-header-ymf271-clock header))
1139+ (:ymz280b (vgm-header-ymz280b-clock header))
1140+ (:rf5c164 (vgm-header-rf5c164-clock header))
1141+ (:pwm (vgm-header-pwm-clock header))
1142+ (:ay8910 (vgm-header-ay8910-clock header))
1143+ (:dmg (vgm-header-dmg-clock header))
1144+ (:nes-apu (vgm-header-nes-apu-clock header))
1145+ (:multi-pcm (vgm-header-multi-pcm-clock header))
1146+ (:upd7759 (vgm-header-upd7759-clock header))
1147+ (:oki-m6258 (vgm-header-oki-m6258-clock header))
1148+ (:oki-m6295 (vgm-header-oki-m6295-clock header))
1149+ (:k051649 (vgm-header-k051649-clock header))
1150+ (:k054539 (vgm-header-k054539-clock header))
1151+ (:huc6280 (vgm-header-huc6280-clock header))
1152+ (:c140 (vgm-header-c140-clock header))
1153+ (:k053260 (vgm-header-k053260-clock header))
1154+ (:pokey (vgm-header-pokey-clock header))
1155+ (:qsound (vgm-header-qsound-clock header))
1156+ (:scsp (vgm-header-scsp-clock header))
1157+ (:wonderswan (vgm-header-wonderswan-clock header))
1158+ (:vsu (vgm-header-vsu-clock header))
1159+ (:saa1099 (vgm-header-saa1099-clock header))
1160+ (:es5503 (vgm-header-es5503-clock header))
1161+ (:es5506 (vgm-header-es5506-clock header))
1162+ (:c352 (vgm-header-c352-clock header))
1163+ (:x1-010 (vgm-header-x1-010-clock header))
1164+ (:ga20 (vgm-header-ga20-clock header))
1165+ (otherwise (error "Attempted to check for the existence of an unknown chip: ~a" chip))))))
1166+
1167+(define-typed-fn vgm-file-chips-used ((vgm-file vgm))
1168+ (hash-table)
1169+ (declare (optimize (speed 3) (debug 1) (compilation-speed 0) (safety 1)))
1170+ (with-typed-slots ((hash-table known-used-chips)
1171+ (list known-supported-chips)
1172+ (vgm-file-header header))
1173+ vgm
1174+ (let* ((klass (find-class 'vgm-file-header))
1175+ (chip-types (if (= (length known-supported-chips) 0)
1176+ ;; Memoize this
1177+ (setf known-supported-chips
1178+ (loop for slot in (closer-mop:class-slots klass)
1179+ unless (or (%vgm-field-ignore-p slot)
1180+ (eq (%vgm-field-chip-type slot) :unknown))
1181+ collect (%vgm-field-chip-type slot) into types
1182+ finally (return (delete-duplicates types :test #'eql))))
1183+
1184+ ;; Use memoized value
1185+ known-supported-chips)))
1186+ (loop for chip-type in chip-types
1187+ if (hash-table-contains-p known-used-chips chip-type) do
1188+ (incf (the fixnum (gethash chip-type known-used-chips)))
1189+ else if (vgm-file-chip-used-p vgm chip-type) do
1190+ (setf (gethash chip-type known-used-chips) 1)))
1191+ known-used-chips))
1192+
1193+(define-typed-fn pcm-sample->vgm-sample ((t/int64 sample-num sample-rate-div sample-rate-mul))
1194+ (t/uint32 t)
1195+ (declare (optimize (speed 3) (debug 1) (safety 0) (compilation-speed 0)))
1196+ (muffling (coerce-to-uint32 (truncate (* sample-num sample-rate-div) sample-rate-mul))))
1197+
1198+(define-typed-fn vgm-sample->pcm-sample ((t/int64 sample-num sample-rate-div sample-rate-mul))
1199+ (t/uint32 t)
1200+ (declare (optimize (speed 3) (debug 1) (safety 0) (compilation-speed 0)))
1201+ (muffling (coerce-to-uint32 (truncate (* sample-num sample-rate-mul) sample-rate-div))))