diff options
54 files changed, 5389 insertions, 0 deletions
diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..7fa9f78 --- /dev/null +++ b/.gitignore @@ -0,0 +1,3 @@ +*~ +/ebus-xml/build +/ebus-racket/**/compiled
\ No newline at end of file diff --git a/LICENSE.md b/LICENSE.md new file mode 100644 index 0000000..2e8d244 --- /dev/null +++ b/LICENSE.md @@ -0,0 +1,534 @@ +# LICENSE + +Except otherwise noted license is GPL (see below). + +## 3rd party code + +### ebus-racket/ebus/3rdparty/xexpr-path: +* Source: https://github.com/mordae/racket-xexpr-path +* Terms: *This software is licensed under the same terms and conditions +as Racket. Consult http://download.racket-lang.org/license.html +for more information.* + +### ebus-racket/3rdparty/bzlib +* see https://planet.racket-lang.org/display.ss?owner=bzlib +* Terms: LGPL + +### ebus-racket/3rdparty/zitterbewegung +* see https://planet.racket-lang.org/display.ss?package=uuid-v4.plt&owner=zitterbewegung +* Terms: LGPL + +## GPL text + +``` + GNU GENERAL PUBLIC LICENSE + Version 2, June 1991 + + Copyright (C) 1989, 1991 Free Software Foundation, Inc. + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The licenses for most software are designed to take away your +freedom to share and change it. By contrast, the GNU General Public +License is intended to guarantee your freedom to share and change free +software--to make sure the software is free for all its users. This +General Public License applies to most of the Free Software +Foundation's software and to any other program whose authors commit to +using it. (Some other Free Software Foundation software is covered by +the GNU Library General Public License instead.) You can apply it to +your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +this service if you wish), that you receive source code or can get it +if you want it, that you can change the software or use pieces of it +in new free programs; and that you know you can do these things. + + To protect your rights, we need to make restrictions that forbid +anyone to deny you these rights or to ask you to surrender the rights. +These restrictions translate to certain responsibilities for you if you +distribute copies of the software, or if you modify it. + + For example, if you distribute copies of such a program, whether +gratis or for a fee, you must give the recipients all the rights that +you have. You must make sure that they, too, receive or can get the +source code. And you must show them these terms so they know their +rights. + + We protect your rights with two steps: (1) copyright the software, and +(2) offer you this license which gives you legal permission to copy, +distribute and/or modify the software. + + Also, for each author's protection and ours, we want to make certain +that everyone understands that there is no warranty for this free +software. If the software is modified by someone else and passed on, we +want its recipients to know that what they have is not the original, so +that any problems introduced by others will not reflect on the original +authors' reputations. + + Finally, any free program is threatened constantly by software +patents. We wish to avoid the danger that redistributors of a free +program will individually obtain patent licenses, in effect making the +program proprietary. To prevent this, we have made it clear that any +patent must be licensed for everyone's free use or not licensed at all. + + The precise terms and conditions for copying, distribution and +modification follow. + + GNU GENERAL PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + 0. This License applies to any program or other work which contains +a notice placed by the copyright holder saying it may be distributed +under the terms of this General Public License. The "Program", below, +refers to any such program or work, and a "work based on the Program" +means either the Program or any derivative work under copyright law: +that is to say, a work containing the Program or a portion of it, +either verbatim or with modifications and/or translated into another +language. (Hereinafter, translation is included without limitation in +the term "modification".) Each licensee is addressed as "you". + +Activities other than copying, distribution and modification are not +covered by this License; they are outside its scope. The act of +running the Program is not restricted, and the output from the Program +is covered only if its contents constitute a work based on the +Program (independent of having been made by running the Program). +Whether that is true depends on what the Program does. + + 1. You may copy and distribute verbatim copies of the Program's +source code as you receive it, in any medium, provided that you +conspicuously and appropriately publish on each copy an appropriate +copyright notice and disclaimer of warranty; keep intact all the +notices that refer to this License and to the absence of any warranty; +and give any other recipients of the Program a copy of this License +along with the Program. + +You may charge a fee for the physical act of transferring a copy, and +you may at your option offer warranty protection in exchange for a fee. + + 2. You may modify your copy or copies of the Program or any portion +of it, thus forming a work based on the Program, and copy and +distribute such modifications or work under the terms of Section 1 +above, provided that you also meet all of these conditions: + + a) You must cause the modified files to carry prominent notices + stating that you changed the files and the date of any change. + + b) You must cause any work that you distribute or publish, that in + whole or in part contains or is derived from the Program or any + part thereof, to be licensed as a whole at no charge to all third + parties under the terms of this License. + + c) If the modified program normally reads commands interactively + when run, you must cause it, when started running for such + interactive use in the most ordinary way, to print or display an + announcement including an appropriate copyright notice and a + notice that there is no warranty (or else, saying that you provide + a warranty) and that users may redistribute the program under + these conditions, and telling the user how to view a copy of this + License. (Exception: if the Program itself is interactive but + does not normally print such an announcement, your work based on + the Program is not required to print an announcement.) + +These requirements apply to the modified work as a whole. If +identifiable sections of that work are not derived from the Program, +and can be reasonably considered independent and separate works in +themselves, then this License, and its terms, do not apply to those +sections when you distribute them as separate works. But when you +distribute the same sections as part of a whole which is a work based +on the Program, the distribution of the whole must be on the terms of +this License, whose permissions for other licensees extend to the +entire whole, and thus to each and every part regardless of who wrote it. + +Thus, it is not the intent of this section to claim rights or contest +your rights to work written entirely by you; rather, the intent is to +exercise the right to control the distribution of derivative or +collective works based on the Program. + +In addition, mere aggregation of another work not based on the Program +with the Program (or with a work based on the Program) on a volume of +a storage or distribution medium does not bring the other work under +the scope of this License. + + 3. You may copy and distribute the Program (or a work based on it, +under Section 2) in object code or executable form under the terms of +Sections 1 and 2 above provided that you also do one of the following: + + a) Accompany it with the complete corresponding machine-readable + source code, which must be distributed under the terms of Sections + 1 and 2 above on a medium customarily used for software interchange; or, + + b) Accompany it with a written offer, valid for at least three + years, to give any third party, for a charge no more than your + cost of physically performing source distribution, a complete + machine-readable copy of the corresponding source code, to be + distributed under the terms of Sections 1 and 2 above on a medium + customarily used for software interchange; or, + + c) Accompany it with the information you received as to the offer + to distribute corresponding source code. (This alternative is + allowed only for noncommercial distribution and only if you + received the program in object code or executable form with such + an offer, in accord with Subsection b above.) + +The source code for a work means the preferred form of the work for +making modifications to it. For an executable work, complete source +code means all the source code for all modules it contains, plus any +associated interface definition files, plus the scripts used to +control compilation and installation of the executable. However, as a +special exception, the source code distributed need not include +anything that is normally distributed (in either source or binary +form) with the major components (compiler, kernel, and so on) of the +operating system on which the executable runs, unless that component +itself accompanies the executable. + +If distribution of executable or object code is made by offering +access to copy from a designated place, then offering equivalent +access to copy the source code from the same place counts as +distribution of the source code, even though third parties are not +compelled to copy the source along with the object code. + + 4. You may not copy, modify, sublicense, or distribute the Program +except as expressly provided under this License. Any attempt +otherwise to copy, modify, sublicense or distribute the Program is +void, and will automatically terminate your rights under this License. +However, parties who have received copies, or rights, from you under +this License will not have their licenses terminated so long as such +parties remain in full compliance. + + 5. You are not required to accept this License, since you have not +signed it. However, nothing else grants you permission to modify or +distribute the Program or its derivative works. These actions are +prohibited by law if you do not accept this License. Therefore, by +modifying or distributing the Program (or any work based on the +Program), you indicate your acceptance of this License to do so, and +all its terms and conditions for copying, distributing or modifying +the Program or works based on it. + + 6. Each time you redistribute the Program (or any work based on the +Program), the recipient automatically receives a license from the +original licensor to copy, distribute or modify the Program subject to +these terms and conditions. You may not impose any further +restrictions on the recipients' exercise of the rights granted herein. +You are not responsible for enforcing compliance by third parties to +this License. + + 7. If, as a consequence of a court judgment or allegation of patent +infringement or for any other reason (not limited to patent issues), +conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot +distribute so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you +may not distribute the Program at all. For example, if a patent +license would not permit royalty-free redistribution of the Program by +all those who receive copies directly or indirectly through you, then +the only way you could satisfy both it and this License would be to +refrain entirely from distribution of the Program. + +If any portion of this section is held invalid or unenforceable under +any particular circumstance, the balance of the section is intended to +apply and the section as a whole is intended to apply in other +circumstances. + +It is not the purpose of this section to induce you to infringe any +patents or other property right claims or to contest validity of any +such claims; this section has the sole purpose of protecting the +integrity of the free software distribution system, which is +implemented by public license practices. Many people have made +generous contributions to the wide range of software distributed +through that system in reliance on consistent application of that +system; it is up to the author/donor to decide if he or she is willing +to distribute software through any other system and a licensee cannot +impose that choice. + +This section is intended to make thoroughly clear what is believed to +be a consequence of the rest of this License. + + 8. If the distribution and/or use of the Program is restricted in +certain countries either by patents or by copyrighted interfaces, the +original copyright holder who places the Program under this License +may add an explicit geographical distribution limitation excluding +those countries, so that distribution is permitted only in or among +countries not thus excluded. In such case, this License incorporates +the limitation as if written in the body of this License. + + 9. The Free Software Foundation may publish revised and/or new versions +of the General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + +Each version is given a distinguishing version number. If the Program +specifies a version number of this License which applies to it and "any +later version", you have the option of following the terms and conditions +either of that version or of any later version published by the Free +Software Foundation. If the Program does not specify a version number of +this License, you may choose any version ever published by the Free Software +Foundation. + + 10. If you wish to incorporate parts of the Program into other free +programs whose distribution conditions are different, write to the author +to ask for permission. For software which is copyrighted by the Free +Software Foundation, write to the Free Software Foundation; we sometimes +make exceptions for this. Our decision will be guided by the two goals +of preserving the free status of all derivatives of our free software and +of promoting the sharing and reuse of software generally. + + NO WARRANTY + + 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY +FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN +OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES +PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED +OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS +TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE +PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, +REPAIR OR CORRECTION. + + 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR +REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, +INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING +OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED +TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY +YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER +PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE +POSSIBILITY OF SUCH DAMAGES. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to the public, the best way to achieve this is to make it +free software which everyone can redistribute and change under these terms. + + To do so, attach the following notices to the program. It is safest +to attach them to the start of each source file to most effectively +convey the exclusion of warranty; and each file should have at least +the "copyright" line and a pointer to where the full notice is found. + + <one line to give the program's name and a brief idea of what it does.> + Copyright (C) <year> <name of author> + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License version 2 + as published by the Free Software Foundation. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + + +Also add information on how to contact you by electronic and paper mail. + +If the program is interactive, make it output a short notice like this +when it starts in an interactive mode: + + Gnomovision version 69, Copyright (C) year name of author + Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type `show c' for details. + +The hypothetical commands `show w' and `show c' should show the appropriate +parts of the General Public License. Of course, the commands you use may +be called something other than `show w' and `show c'; they could even be +mouse-clicks or menu items--whatever suits your program. + +You should also get your employer (if you work as a programmer) or your +school, if any, to sign a "copyright disclaimer" for the program, if +necessary. Here is a sample; alter the names: + + Yoyodyne, Inc., hereby disclaims all copyright interest in the program + `Gnomovision' (which makes passes at compilers) written by James Hacker. + + <signature of Ty Coon>, 1 April 1989 + Ty Coon, President of Vice + +This General Public License does not permit incorporating your program into +proprietary programs. If your program is a subroutine library, you may +consider it more useful to permit linking proprietary applications with the +library. If this is what you want to do, use the GNU Library General +Public License instead of this License. +``` + + +## LGPL Text + +``` + GNU LESSER GENERAL PUBLIC LICENSE + Version 3, 29 June 2007 + + Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/> + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + + This version of the GNU Lesser General Public License incorporates +the terms and conditions of version 3 of the GNU General Public +License, supplemented by the additional permissions listed below. + + 0. Additional Definitions. + + As used herein, "this License" refers to version 3 of the GNU Lesser +General Public License, and the "GNU GPL" refers to version 3 of the GNU +General Public License. + + "The Library" refers to a covered work governed by this License, +other than an Application or a Combined Work as defined below. + + An "Application" is any work that makes use of an interface provided +by the Library, but which is not otherwise based on the Library. +Defining a subclass of a class defined by the Library is deemed a mode +of using an interface provided by the Library. + + A "Combined Work" is a work produced by combining or linking an +Application with the Library. The particular version of the Library +with which the Combined Work was made is also called the "Linked +Version". + + The "Minimal Corresponding Source" for a Combined Work means the +Corresponding Source for the Combined Work, excluding any source code +for portions of the Combined Work that, considered in isolation, are +based on the Application, and not on the Linked Version. + + The "Corresponding Application Code" for a Combined Work means the +object code and/or source code for the Application, including any data +and utility programs needed for reproducing the Combined Work from the +Application, but excluding the System Libraries of the Combined Work. + + 1. Exception to Section 3 of the GNU GPL. + + You may convey a covered work under sections 3 and 4 of this License +without being bound by section 3 of the GNU GPL. + + 2. Conveying Modified Versions. + + If you modify a copy of the Library, and, in your modifications, a +facility refers to a function or data to be supplied by an Application +that uses the facility (other than as an argument passed when the +facility is invoked), then you may convey a copy of the modified +version: + + a) under this License, provided that you make a good faith effort to + ensure that, in the event an Application does not supply the + function or data, the facility still operates, and performs + whatever part of its purpose remains meaningful, or + + b) under the GNU GPL, with none of the additional permissions of + this License applicable to that copy. + + 3. Object Code Incorporating Material from Library Header Files. + + The object code form of an Application may incorporate material from +a header file that is part of the Library. You may convey such object +code under terms of your choice, provided that, if the incorporated +material is not limited to numerical parameters, data structure +layouts and accessors, or small macros, inline functions and templates +(ten or fewer lines in length), you do both of the following: + + a) Give prominent notice with each copy of the object code that the + Library is used in it and that the Library and its use are + covered by this License. + + b) Accompany the object code with a copy of the GNU GPL and this license + document. + + 4. Combined Works. + + You may convey a Combined Work under terms of your choice that, +taken together, effectively do not restrict modification of the +portions of the Library contained in the Combined Work and reverse +engineering for debugging such modifications, if you also do each of +the following: + + a) Give prominent notice with each copy of the Combined Work that + the Library is used in it and that the Library and its use are + covered by this License. + + b) Accompany the Combined Work with a copy of the GNU GPL and this license + document. + + c) For a Combined Work that displays copyright notices during + execution, include the copyright notice for the Library among + these notices, as well as a reference directing the user to the + copies of the GNU GPL and this license document. + + d) Do one of the following: + + 0) Convey the Minimal Corresponding Source under the terms of this + License, and the Corresponding Application Code in a form + suitable for, and under terms that permit, the user to + recombine or relink the Application with a modified version of + the Linked Version to produce a modified Combined Work, in the + manner specified by section 6 of the GNU GPL for conveying + Corresponding Source. + + 1) Use a suitable shared library mechanism for linking with the + Library. A suitable mechanism is one that (a) uses at run time + a copy of the Library already present on the user's computer + system, and (b) will operate properly with a modified version + of the Library that is interface-compatible with the Linked + Version. + + e) Provide Installation Information, but only if you would otherwise + be required to provide such information under section 6 of the + GNU GPL, and only to the extent that such information is + necessary to install and execute a modified version of the + Combined Work produced by recombining or relinking the + Application with a modified version of the Linked Version. (If + you use option 4d0, the Installation Information must accompany + the Minimal Corresponding Source and Corresponding Application + Code. If you use option 4d1, you must provide the Installation + Information in the manner specified by section 6 of the GNU GPL + for conveying Corresponding Source.) + + 5. Combined Libraries. + + You may place library facilities that are a work based on the +Library side by side in a single library together with other library +facilities that are not Applications and are not covered by this +License, and convey such a combined library under terms of your +choice, if you do both of the following: + + a) Accompany the combined library with a copy of the same work based + on the Library, uncombined with any other library facilities, + conveyed under the terms of this License. + + b) Give prominent notice with the combined library that part of it + is a work based on the Library, and explaining where to find the + accompanying uncombined form of the same work. + + 6. Revised Versions of the GNU Lesser General Public License. + + The Free Software Foundation may publish revised and/or new versions +of the GNU Lesser General Public License from time to time. Such new +versions will be similar in spirit to the present version, but may +differ in detail to address new problems or concerns. + + Each version is given a distinguishing version number. If the +Library as you received it specifies that a certain numbered version +of the GNU Lesser General Public License "or any later version" +applies to it, you have the option of following the terms and +conditions either of that published version or of any later version +published by the Free Software Foundation. If the Library as you +received it does not specify a version number of the GNU Lesser +General Public License, you may choose any version of the GNU Lesser +General Public License ever published by the Free Software Foundation. + + If the Library as you received it specifies that a proxy can decide +whether future versions of the GNU Lesser General Public License shall +apply, that proxy's public statement of acceptance of any version is +permanent authorization for you to choose that version for the +Library. +```
\ No newline at end of file diff --git a/README.md b/README.md new file mode 100644 index 0000000..983d397 --- /dev/null +++ b/README.md @@ -0,0 +1,9 @@ +# Ebus Tools + +## ebus-racket + +Ebus protocol parser written in [racket](http://www.racket-lang.org). + +## ebus-xml + +Ebus protocol specification (devices, packets, fields) in xml.
\ No newline at end of file diff --git a/doc/dump_2011-12-17_23-04-00.bin b/doc/dump_2011-12-17_23-04-00.bin Binary files differnew file mode 100644 index 0000000..fa77889 --- /dev/null +++ b/doc/dump_2011-12-17_23-04-00.bin diff --git a/doc/dump_2012-03-01.bin b/doc/dump_2012-03-01.bin Binary files differnew file mode 100644 index 0000000..6658bbf --- /dev/null +++ b/doc/dump_2012-03-01.bin diff --git a/doc/print_dump.sh b/doc/print_dump.sh new file mode 100755 index 0000000..a50ed40 --- /dev/null +++ b/doc/print_dump.sh @@ -0,0 +1,6 @@ +#!/bin/sh +hexdump -v \ + -e '/1 "%_ad# "' \ + -e '/1 " = %02x hex "' \ + -e '/1 " = %03u dec\n"' \ + $* diff --git a/doc/sample-ebus-dump-started-2014-08-02 b/doc/sample-ebus-dump-started-2014-08-02 Binary files differnew file mode 100644 index 0000000..6d66a67 --- /dev/null +++ b/doc/sample-ebus-dump-started-2014-08-02 diff --git a/doc/sample_dump_1_1min.bin b/doc/sample_dump_1_1min.bin Binary files differnew file mode 100644 index 0000000..f0ec73e --- /dev/null +++ b/doc/sample_dump_1_1min.bin diff --git a/doc/sample_dump_2.bin b/doc/sample_dump_2.bin Binary files differnew file mode 100644 index 0000000..f88a9c6 --- /dev/null +++ b/doc/sample_dump_2.bin diff --git a/ebus-racket/3rdparty/bzlib/base/args.ss b/ebus-racket/3rdparty/bzlib/base/args.ss new file mode 100644 index 0000000..dd4659a --- /dev/null +++ b/ebus-racket/3rdparty/bzlib/base/args.ss @@ -0,0 +1,150 @@ +#lang scheme/base +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; BASE.plt +;; +;; +;; Bonzai Lab, LLC. All rights reserved. +;; +;; Licensed under LGPL. +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; args.ss - utility for helping processing syntax-based arguments (does not belong here) +;; yc 9/21/2009 - first version +;; yc 9/25/2009 - move from port.plt to base.plt +(require (for-syntax scheme/base) + scheme/match) + +;; convert an argument (and an optional argument) into an identifier +;; p => p +;; (p v ...) => p +(define (arg->identifier stx) + (syntax-case stx () + (p + (symbol? (syntax->datum #'p)) + #'p) + ;; an optional arg. + ((p . _) + #'p))) + +;; (a (b v1) #:c (c v2)) => (a b c) +(define (args->identifiers stx) + (syntax-case stx () + (() + #'()) + ((p . rest) + (keyword? (syntax->datum #'p)) + (args->identifiers #'rest)) + ((p . rest) + #`(#,(arg->identifier #'p) . #,(args->identifiers #'rest))))) + +(define (args->kw+identifiers stx) + (syntax-case stx () + (() + #'()) + ((p . rest) + (keyword? (syntax->datum #'p)) + #`(p . #,(args->identifiers #'rest))) + ((p . rest) + #`(#,(arg->identifier #'p) . #,(args->identifiers #'rest))))) + +(define (args->kw-identifiers stx) + (syntax-case stx () + (() + #'()) + ((p . rest) + (keyword? (syntax->datum #'p)) + #`(p . #,(args->identifiers #'rest))) + ((p . rest) + (args->kw-identifiers #'rest)))) +;; (trace args->kw-identifiers) + +(define (args->kw-args stx) + (syntax-case stx () + (() + #'()) + ((p . rest) + (keyword? (syntax->datum #'p)) + #'(p . rest)) + ((p . rest) + (args->kw-args #'rest)))) + +(define (args->non-kw-identifiers stx) + (syntax-case stx () + (() + #'()) + ((p . rest) + (keyword? (syntax->datum #'p)) + #'()) + ((p . rest) + #`(#,(arg->identifier #'p) . #,(args->non-kw-identifiers #'rest))))) + +(define (args->non-kw-args stx) + (syntax-case stx () + (() + #'()) + ((p . rest) + (keyword? (syntax->datum #'p)) + #'()) + ((p . rest) + #`(p . #,(args->non-kw-args #'rest))))) + +(provide arg->identifier + args->identifiers + args->kw+identifiers + args->kw-identifiers + args->non-kw-identifiers + args->kw-args + args->non-kw-args + ) + +;;; typed args... +;;; a typed args look like an optional argument, except that +;;; it has the following: +;;; (id type?) (id type? default) +(define (typed-arg? stx) + (match (syntax->datum stx) + ((list (? symbol? _) _) #t) + ((list (? symbol? _) _ _) #t) + (else #f))) + +(define (typed-arg->arg stx) + (syntax-case stx () + ((p type) + #'p) + ((p type default) + #'(p default)))) + +(define (typed-args->args stx) + (syntax-case stx () + (() + #'()) + ((p . rest) + (keyword? (syntax->datum #'p)) + #`(p . #,(typed-args->args #'rest))) + ((p . rest) + #`(#,(typed-arg->arg #'p) . #,(typed-args->args #'rest))))) + +(define (typed-arg->type stx) + (syntax-case stx () + ((p type) + #'type) + ((p type default) + #'type))) + +(define (typed-args->types stx) + (syntax-case stx () + (() + #'()) + ((p . rest) + (keyword? (syntax->datum #'p)) + (typed-args->types #'rest)) + ((p . rest) + #`(#,(typed-arg->type #'p) . #,(typed-args->types #'rest))))) + +(provide typed-args->args + typed-args->types + typed-arg->arg + typed-arg->type + ) + + + diff --git a/ebus-racket/3rdparty/bzlib/base/assert.ss b/ebus-racket/3rdparty/bzlib/base/assert.ss new file mode 100644 index 0000000..aea9349 --- /dev/null +++ b/ebus-racket/3rdparty/bzlib/base/assert.ss @@ -0,0 +1,150 @@ +#lang scheme/base +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; BASE.plt +;; +;; +;; Bonzai Lab, LLC. All rights reserved. +;; +;; Licensed under LGPL. +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; assert.ss - utility for verifying result of the values... +;; yc 1/9/2010 - fixed let/assert! and let*/assert to allow for optional test function +;; yc 2/10/2010 - move listof? to list.ss +(require (for-syntax scheme/base "args.ss") + "base.ss" + (only-in mzlib/etc identity) + (prefix-in c: scheme/contract) + ) + +(define-struct (exn:assert! exn) (test? exp expected actual)) + +(define (error/assert! test? exp expected actual (name 'assert!)) + (raise (make-exn:assert! (if (not expected) + (format "~a assert! (~a ~a); actual ~a" name test? exp actual) + (format "~a assert! (~a ~a ~a); actual ~a" name test? exp expected actual)) + (current-continuation-marks) test? exp expected actual))) + +;; assert! v test? v2 +;; assert! v true? +;; assert! v v2 (use equal for comparison) => we can get rid of this form... +(define-syntax named-assert! + (syntax-rules () + ((~ name exp test? expected) + (let ((actual exp)) + (if (test? actual expected) + actual + (error/assert! 'test? 'exp 'expected actual 'name)))) + ((~ name exp test?) + (let ((actual exp)) + (if (test? actual) + actual + (error/assert! 'test? 'exp #f actual 'name)))) + ((~ name exp) + (named-assert! name exp identity)) + )) + +(define-syntax assert! + (syntax-rules () + ((~ args ...) + (named-assert! assert! args ...)))) + + +(define-syntax let/assert! + (syntax-rules () + ((~ ((id test? arg) ...) exp exp2 ...) + (let/assert! let/assert! ((id test? arg) ...) exp exp2 ...)) + ((~ name ((id test? arg) ...) exp exp2 ...) + (let ((id arg) ...) + (let ((id (named-assert! name id test?)) ...) exp exp2 ...))) + ((~ ((id arg) ...) exp exp2 ...) + (let/assert! let/assert! ((id identity arg) ...) exp exp2 ...)) + ((~ name ((id arg) ...) exp exp2 ...) + (let/assert! name ((id identity arg) ...) exp exp2 ...)) + )) + +(define-syntax let*/assert! + (syntax-rules () + ((~ name () exp exp2 ...) + (begin exp exp2 ...)) + ((~ ((id test? arg) ...) exp exp2 ...) + (let*/assert! let*/assert! ((id test? arg) ...) exp exp2 ...)) + ((~ name ((id test? arg) rest ...) exp exp2 ...) + (let/assert! name ((id test? arg)) + (let*/assert! name (rest ...) exp exp2 ...))) + ((~ ((id arg) ...) exp exp2 ...) + (let*/assert! ((id identity arg) ...) exp exp2 ...)) + ((~ name ((id arg) ...) exp exp2 ...) + (let*/assert! name ((id identity arg) ...) exp exp2 ...)) + )) + +(define-syntax (lambda/assert! stx) + (syntax-case stx () + ((~ name (a1 ... rest-id rest-type) exp exp2 ...) + (and (symbol? (syntax->datum #'name)) + (symbol? (syntax->datum #'rest-id))) + (with-syntax (((arg ...) + (typed-args->args #'(a1 ...))) + ((id ...) + (args->identifiers #'(a1 ...))) + ((type ...) + (typed-args->types #'(a1 ...))) + ) + #'(lambda (arg ... . rest-id) + (let/assert! name ((id type id) ... + (rest-id rest-type rest-id)) + exp exp2 ...)))) + ((~ name (a1 ...) exp exp2 ...) + (symbol? (syntax->datum #'name)) + (with-syntax (((arg ...) + (typed-args->args #'(a1 ...))) + ((id ...) + (args->identifiers #'(a1 ...))) + ((type ...) + (typed-args->types #'(a1 ...))) + ) + #'(lambda (arg ...) ;; this is the general idea.. but this general idea doesn't fully work... + (let/assert! name ((id type id) ...) + exp exp2 ...)))) + ((~ (a1 ...) exp exp2 ...) + #'(~ lambda/assert! (a1 ...) exp exp2 ...)) + )) + +(define-syntax define/assert! + (syntax-rules () + ((~ (name . args) exp exp2 ...) + (define name + (lambda/assert! name args exp exp2 ...))))) + +(provide define/assert! + lambda/assert! + let*/assert! + let/assert! + assert! + named-assert! + ) + +(c:provide/contract + (struct exn:assert! ((message string?) + (continuation-marks continuation-mark-set?) + (test? c:any/c) + (exp c:any/c) + (expected c:any/c) + (actual c:any/c))) + (error/assert! (c:->* (c:any/c c:any/c c:any/c c:any/c) + (symbol?) + c:any)) + ) + +#| +;; if I want to define a contract... with the following form it can become quite complicated!!! + +;; we can also guard the arguments @ regular lamda and also let statement... +;; guarding the arguments... +(define/assert! (foo (a number?) (b number? 5) #:c (c number? 5)) + (+ a b c)) + +(define/assert! (foo2 (a number?) (b number? 10) . (rest (listof? number?))) + (apply + a b rest)) +(let/assert! ((a number? 3) (b number? 'abc)) + (+ a b)) +;;|#
\ No newline at end of file diff --git a/ebus-racket/3rdparty/bzlib/base/base.ss b/ebus-racket/3rdparty/bzlib/base/base.ss new file mode 100644 index 0000000..6ec8496 --- /dev/null +++ b/ebus-racket/3rdparty/bzlib/base/base.ss @@ -0,0 +1,211 @@ +#lang scheme/base +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; BASE.plt - common routines that are shared by all other bzlib modules +;; +;; in a way, base.plt is the most fundamental module of the whole bzlib stack +;; and as such it also is the lowest level code. We are not likely to +;; fix the code any time soon, and hence any of the functions here are +;; explicitly likely to be obsoleted or moved elsewhere. +;; +;; Proceed with caution. +;; +;; +;; Bonzai Lab, LLC. All rights reserved. +;; +;; Licensed under LGPL. +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; base.ss - basic functionalities that do not belong anywhere else. +;; yc 9/8/2009 - first version +;; yc 9/25/2009 - moved assert! & let/assert! to assert.ss +;; yc 1/12/2010 - add let*/if +;; yc 2/5/2010 - add define-case-test & case/equal? & case/string-ci=? +;; yc 2/13/2010 - add isa/c +(require (for-syntax scheme/base) + scheme/list + scheme/port + mzlib/etc + mzlib/trace + scheme/contract + scheme/function + ) + +(define-syntax (trace-lambda stx) + (syntax-case stx () + ((~ args exp exp2 ...) + #'(letrec ((func + (lambda args exp exp2 ...))) + (trace func) + func)))) + +(define-syntax (if-it stx) + (syntax-case stx () + [(src-if-it test then else) + (syntax-case (datum->syntax (syntax src-if-it) 'it) () + [it (syntax (let ([it test]) (if it then else)))])])) + +(define-syntax (when-it stx) + (syntax-case stx () + ((~ test? exp exp2 ...) + (with-syntax ((it (datum->syntax #'~ 'it))) + #'(let ((it test?)) (when it exp exp2 ...)))))) + +(define-syntax (cond-it stx) + (syntax-case stx (else) + ((cond-it (else exp exp2 ...)) + #'(begin exp exp2 ...)) + ((cond-it (test? exp exp2 ...)) + (with-syntax ((it (datum->syntax #'cond-it 'it))) + #'(let ((it test?)) (when it exp exp2 ...)))) + ((cond-it (test? exp exp2 ...) cond cond2 ...) + (with-syntax ((it (datum->syntax #'cond-it 'it))) + #'(let ((it test?)) + (if it (begin exp exp2 ...) + (cond-it cond cond2 ...))))))) + +(define-syntax while + (syntax-rules () + ((while test exp exp2 ...) + (let loop () + (when test + exp exp2 ... + (loop)))) + )) + +(define-syntax let*/if + (syntax-rules () + ((~ ((arg val)) exp exp2 ...) + (let ((arg val)) + (if (not arg) + #f + (begin exp exp2 ...)))) + ((~ ((arg val) (arg-rest val-rest) ...) exp exp2 ...) + (let ((arg val)) + (if (not arg) + #f + (let*/if ((arg-rest val-rest) ...) exp exp2 ...)))))) + +(define-syntax case/pred? + (syntax-rules (else) + ((~ pred? (else exp exp2 ...)) + (begin exp exp2 ...)) + ((~ pred? ((d d2 ...) exp exp2 ...)) + (when (ormap pred? (list d d2 ...)) + exp exp2 ...)) + ((~ pred? ((d d2 ...) exp exp2 ...) rest ...) + (if (ormap pred? (list d d2 ...)) + (begin exp exp2 ...) + (case/pred? pred? rest ...))))) + +(define-syntax define-case/test? + (syntax-rules () + ((~ name test?) + (define-syntax name + (syntax-rules () + ((~ v clause clause2 (... ...)) + (case/pred? (curry test? v) clause clause2 (... ...))))) + ))) + + +(define-case/test? case/equal? equal?) +(define-case/test? case/string-ci=? string-ci=?) + +;;|# + +;; (trace load-proc) +;; a generic version of apply & keyword-apply that requires +;; no sorting of the parameter args... +(define (apply* proc . args) + (define (filter-kws args (acc '())) + (cond ((null? args) (reverse acc)) + ((keyword? (car args)) + (filter-kws (cdr args) (cons (car args) acc))) + (else + (filter-kws (cdr args) acc)))) + (define (filter-kw-vals args (acc '())) + (cond ((null? args) (reverse acc)) + ((keyword? (car args)) + (if (null? (cdr args)) ;; this is wrong!!! + (error 'kw-apply "keyword ~a not followed by a value" (car args)) + (filter-kw-vals (cddr args) (cons (cadr args) acc)))) + (else + (filter-kw-vals (cdr args) acc)))) + (define (filter-non-kw-vals args (acc '())) + (cond ((null? args) (reverse acc)) + ((keyword? (car args)) + (if (null? (cdr args)) + (error 'kw-apply "keyword ~a not followed by a value" (car args)) + (filter-non-kw-vals (cddr args) acc))) + (else + (filter-non-kw-vals (cdr args) (cons (car args) acc))))) + (define (sorted-kw+args args) + (let ((kw+args (sort (map (lambda (kw vals) + (cons kw vals)) + (filter-kws args) + (filter-kw-vals args)) + (lambda (kv kv1) + (keyword<? (car kv) (car kv1)))))) + (values (map car kw+args) (map cdr kw+args)))) + (define (normalize-args args) + (cond ((list? (last args)) + (apply list* args)) + (else (error 'apply* "Expect last arg as a list, given ~a" (last args))))) + (let ((args (normalize-args args))) + (let-values (((kws vals) + (sorted-kw+args args))) + (keyword-apply proc kws vals + (filter-non-kw-vals args))))) + + + +(define (value-or v (default #f)) + (if (not v) default v)) + +(define (null-or v (default #f)) + (if (null? v) default v)) + +(define (thunk? p) + (and (procedure? p) + (let ((a (procedure-arity p))) + (cond ((arity-at-least? a) + (= (arity-at-least-value a) 0)) + ((number? a) (= a 0)) + ((list? a) (member 0 a)))))) + +;; isa/c +;; this is useful but I did not include it until a bit too late... hmm... +(define isa/c (-> any/c any)) + +(define (typeof/c contract) + (-> contract any)) + +(provide (all-from-out mzlib/etc + scheme/function + ) + trace-lambda + if-it + when-it + cond-it + while + let*/if + case/pred? + define-case/test? + case/equal? + case/string-ci=? + isa/c + typeof/c + ) + + +(provide/contract + (apply* (->* (procedure?) + () + #:rest (listof any/c) + any)) + (value-or (->* (any/c) + (any/c) + any)) + (null-or (->* (any/c) + (any/c) + any)) + (thunk? (-> any/c boolean?)) + ) diff --git a/ebus-racket/3rdparty/bzlib/base/bytes.ss b/ebus-racket/3rdparty/bzlib/base/bytes.ss new file mode 100644 index 0000000..0edab66 --- /dev/null +++ b/ebus-racket/3rdparty/bzlib/base/bytes.ss @@ -0,0 +1,206 @@ +#lang scheme/base +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; BASE.plt - common routines that are shared by all other bzlib modules +;; +;; in a way, base.plt is the most fundamental module of the whole bzlib stack +;; and as such it also is the lowest level code. We are not likely to +;; fix the code any time soon, and hence any of the functions here are +;; explicitly likely to be obsoleted or moved elsewhere. +;; +;; Proceed with caution. +;; +;; +;; Bonzai Lab, LLC. All rights reserved. +;; +;; Licensed under LGPL. +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; bytes.ss - provides utility functions that works with bytes +;; yc 10/19/2009 - first version +;; yc 10/23/2009 - add read-bytes-avail that'll return the currently available bytes +;; yc 10/24/2009 - add read-byte-list & read-byte-list/timeout +;; yc 1/18/2010 - fix the issue that call-with-output-bytes was not available until v > 4.2 +;; yc 2/5/2010 - added string-char-ratios for accurately determien the ratio of ascii/latin-1/unicode chars +(require scheme/port scheme/contract "version-case.ss" "base.ss") + +;; call-with-output-bytes is not available until 4.1 +(define *call-with-output-bytes + (+:version>= "4.2" + call-with-output-bytes + (lambda (proc) + (let ((out (open-output-bytes))) + (dynamic-wind void + (lambda () + (proc out)) + (lambda () + (get-output-bytes out))))))) + +(define (port->bytes/charset in charset-in charset-out) + (*call-with-output-bytes + (lambda (out) + (convert-stream charset-in in charset-out out)))) + +(define (bytes->bytes/charset bytes charset-in charset-out) + (port->bytes/charset (open-input-bytes bytes) charset-in charset-out)) + +(define (bytes/charset->bytes/utf-8 bytes charset) + (bytes->bytes/charset bytes charset "utf-8")) + +(define (bytes/utf-8->bytes/charset bytes charset) + (bytes->bytes/charset bytes "utf-8" charset)) + +;; there are more to handle (specifically charsets). +(define (bytes/charset->string bytes charset) + (bytes->string/utf-8 (bytes/charset->bytes/utf-8 bytes charset))) + +(define (string->bytes/charset string charset) + (bytes/utf-8->bytes/charset (string->bytes/utf-8 string) charset)) + +(define (char-latin-1? c) + (< 0 (char->integer c) 256)) + +(define (char-ascii? c) + (< 0 (char->integer c) 128)) + +(define (string-char-or? s test?) + (define (helper len i) + (if (= len i) #f + (if (test? (string-ref s i)) #t + (helper len (add1 i))))) + (helper (string-length s) 0)) + +(define (string-char-and? s test?) + (define (helper len i) + (if (= len i) #t + (if (not (test? (string-ref s i))) #f + (helper len (add1 i))))) + (helper (string-length s) 0)) + +(define (char-type c) + (let ((i (char->integer c))) + (cond ((< i 128) 'ascii) + ((< i 256) 'latin-1) + (else 'unicode)))) + +(define (string-char-ratios s) + (define (helper ascii latin-1 unicode i len) + (if (= i len) + (values (/ ascii len) + (/ latin-1 len) + (/ unicode len)) + (case (char-type (string-ref s i)) + ((ascii) (helper (add1 ascii) latin-1 unicode (add1 i) len)) + ((latin-1) (helper ascii (add1 latin-1) unicode (add1 i) len)) + (else (helper ascii latin-1 (add1 unicode) (add1 i) len))))) + (if (= (string-length s) 0) + (values 1 0 0) + (helper 0 0 0 0 (string-length s)))) + +(define (string-type s) + (define (helper len i prev) + (if (= len i) prev + (let ((type (char-type (string-ref s i)))) + (case type + ((unicode) type) + ((latin-1) + (helper len (add1 i) (case prev + ((ascii) type) + (else prev)))) + (else (helper len (add1 i) prev)))))) + (helper (string-length s) 0 'ascii)) + +(define (string-latin-1? s) + (string-char-and? s char-latin-1?)) + +(define (string-ascii? s) + (string-char-and? s char-ascii?)) + +(define (char->bytes c) + (string->bytes/utf-8 (string c))) + +(define (split-string-by-bytes-count str num) + (define (maker chars) + (list->string (reverse chars))) + (define (helper str i chars blen acc) + (if (= i (string-length str)) ;; we are done here!!!... + (reverse (if (null? chars) acc + (cons (maker chars) acc))) + (let* ((c (string-ref str i)) + (count (char-utf-8-length c))) + (if (> (+ count blen) num) ;; we are done with this version.... + (if (= blen 0) ;; this means the character itself is greater than the count. + (helper str (add1 i) '() 0 (cons (maker (cons c chars)) acc)) + (helper str i '() 0 (cons (maker chars) acc))) + (helper str (add1 i) (cons c chars) (+ count blen) acc))))) + (helper str 0 '() 0 '())) + +(define (read-bytes-avail num in) + (define (helper bytes) + (let ((len (read-bytes-avail!* bytes in 0 num))) + (cond ((eof-object? len) bytes) + ((number? len) (subbytes bytes 0 len)) + (else ;; this is a *special* value... I don't know what to do with it yet... + (len))))) + (helper (make-bytes num 0))) + +(define (read-byte-list num in) + (define (helper bytes) + (if (eof-object? bytes) + bytes + (bytes->list bytes))) + (helper (read-bytes num in))) + +(define (read-byte-list/timeout num in (timeout #f)) + (define (helper alarm acc count) + (let ((evt (sync alarm in))) + (if (eq? alarm evt) + (reverse acc) + (let ((b (read-byte in))) + (cond ((eof-object? b) + (if (null? acc) + b + (reverse acc))) + ((= (add1 count) num) + (reverse (cons b acc))) + (else + (helper alarm (cons b acc) (add1 count)))))))) + (helper (alarm-evt (+ (current-inexact-milliseconds) (* 1000 (if (not timeout) + +inf.0 + timeout)))) '() 0)) + +(define (read-bytes/timeout num in (timeout #f)) + (define (helper bytes) + (if (eof-object? bytes) + bytes + (list->bytes bytes))) + (helper (read-byte-list/timeout num in timeout))) + +(define (positive-number? n) + (and (number? n) (> n 0))) + +(provide/contract + (char-ascii? (typeof/c char?)) + (char-latin-1? (typeof/c char?)) + (string-char-or? (-> string? (-> char? any) any)) + (string-char-and? (-> string? (-> char? any) any)) + (string-latin-1? (typeof/c string?)) + (string-ascii? (typeof/c string?)) + (char-type (typeof/c char?)) + (string-char-ratios (-> string? (values number? number? number?))) + (string-type (typeof/c string?)) + (split-string-by-bytes-count (-> string? exact-positive-integer? (listof string?))) + (port->bytes/charset (-> input-port? string? string? any)) + (bytes->bytes/charset (-> bytes? string? string? bytes?)) + (bytes/charset->bytes/utf-8 (-> bytes? string? bytes?)) + (bytes/utf-8->bytes/charset (-> bytes? string? bytes?)) + (bytes/charset->string (-> bytes? string? string?)) + (string->bytes/charset (-> string? string? bytes?)) + (read-bytes-avail (-> exact-positive-integer? input-port? bytes?)) + (read-byte-list (-> exact-positive-integer? input-port? bytes?)) + (read-bytes/timeout (->* (exact-positive-integer? input-port?) + ((or/c #f positive-number?)) + bytes?)) + (read-byte-list/timeout (->* (exact-positive-integer? input-port?) + ((or/c #f positive-number?)) + any)) + ) + diff --git a/ebus-racket/3rdparty/bzlib/base/info.ss b/ebus-racket/3rdparty/bzlib/base/info.ss new file mode 100644 index 0000000..f07b881 --- /dev/null +++ b/ebus-racket/3rdparty/bzlib/base/info.ss @@ -0,0 +1,27 @@ +#lang setup/infotab +(define name "bzlib/base: common utilities for bzlib") + +(define blurb + '((p "bzlib/base provides the common utilities that other bzlib packages depend on. Currently this package's interface might drastically change and will not be directly supported until it stablizes."))) + +(define release-notes + '((p "0.6 (1 6) - fixed syntax-identifier-append, added registry-clear!") + (p "0.5 (1 5) - adding read-bytes-avail, read-byte-list, read-byte-list/timeout, read-bytes/timeout, version.ss, version-case.ss, fixed let/assert!, added let*/assert, fixed bytes.ss needing (version) >= 4.1, added let*/if, added isa/c & typeof/c") + (p "0.4 (1 3) - adding bytes.ss & require.ss & syntax.ss (args.ss, assert.ss, syntax.ss, & require.ss are likely to be moved to another package)") + (p "0.3 (1 2) - added assert.ss, args.ss, and refactored group to here from dbd-memcached") + (p "0.2 (1 1) - added assert! & let/assert!") + (p "0.1 (1 0) - first release"))) + +(define categories + '(devtools net misc)) + +(define homepage "http://weblambda.blogspot.com") + +(define required-core-version "4.0") + +(define version "0.6") + +(define repositories '("4.x")) + +(define primary-file "main.ss") + diff --git a/ebus-racket/3rdparty/bzlib/base/list.ss b/ebus-racket/3rdparty/bzlib/base/list.ss new file mode 100644 index 0000000..44b64f0 --- /dev/null +++ b/ebus-racket/3rdparty/bzlib/base/list.ss @@ -0,0 +1,109 @@ + +#lang scheme/base +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; BASE.plt - common routines that are shared by all other bzlib modules +;; +;; in a way, base.plt is the most fundamental module of the whole bzlib stack +;; and as such it also is the lowest level code. We are not likely to +;; fix the code any time soon, and hence any of the functions here are +;; explicitly likely to be obsoleted or moved elsewhere. +;; +;; Proceed with caution. +;; +;; +;; Bonzai Lab, LLC. All rights reserved. +;; +;; Licensed under LGPL. +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; list.ss - basic functionalities that has to do with list processing. +;; yc 9/8/2009 - first version +;; yc 9/25/2009 - moved group from bzlib/dbd-memcached/dht to here; exported scheme/list +;; yc 2/10/2010 - move listof? from assert.ss (not sure why it was there) to list.ss +(require "base.ss" scheme/list scheme/contract) + +(define (assoc/cdr key alist (default #f)) + (if-it (assoc key alist) + (cdr it) + default)) + +(define (assoc/s key alist (default '())) + (let ((it (filter (lambda (kv) + (equal? (car kv) key)) + alist))) + (if (null? it) default it))) + +;; this function is a combo of member & assoc +;; it's useful when we have a malformed alist, where when the +;; pair has no value, the key is retained +;; (or when there is no key, the value is retained) +(define (assoc* key lst (default #f)) + (define (helper rest) + (cond ((null? rest) default) + ;; assoc behavior + ((and (pair? (car rest)) + (equal? key (caar rest))) + (car rest)) + ;; member behavior + ((and (not (pair? (car rest))) + (equal? key (car rest))) + rest) + (else + (helper (cdr rest))))) + ;; (trace helper) + (helper lst)) + +(define (assoc*/cdr key lst (default #f)) + (if-it (assoc* key lst) + (cdr it) + default)) + + +(define (group alist) + ;; for each alist with the same key - group them together!! + (foldl (lambda (kv interim) + (if-it (assoc (car kv) interim) ;; the key already exists... + (cons (cons (car it) (cons (cdr kv) (cdr it))) + (filter (lambda (kv) + (not (equal? it kv))) interim)) + (cons (list (car kv) (cdr kv)) interim))) + '() + alist)) + + +(define (list->unique lst (equal? equal?)) + (reverse (foldl (lambda (item interim) + (if (memf (lambda (item1) + (equal? item item1)) + interim) + interim + (cons item interim))) + '() + lst))) + +(define (listof? type?) + (lambda (args) + (and (list? args) + (andmap type? args)))) + + +(provide/contract + (assoc/cdr (->* (any/c list?) + (any/c) + any)) + (assoc/s (->* (any/c list?) + (any/c) + any)) + (assoc* (->* (any/c list?) + (any/c) + any)) + (assoc*/cdr (->* (any/c list?) + (any/c) + any)) + (group (-> (or/c null? pair?) any)) + (list->unique (->* (pair?) + (procedure?) + any)) + (listof? (-> isa/c isa/c)) + ) +(provide (all-from-out scheme/list)) + diff --git a/ebus-racket/3rdparty/bzlib/base/main.ss b/ebus-racket/3rdparty/bzlib/base/main.ss new file mode 100644 index 0000000..b722783 --- /dev/null +++ b/ebus-racket/3rdparty/bzlib/base/main.ss @@ -0,0 +1,49 @@ +#lang scheme/base +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; BASE.plt - common routines that are shared by all other bzlib modules +;; +;; in a way, base.plt is the most fundamental module of the whole bzlib stack +;; and as such it also is the lowest level code. We are not likely to +;; fix the code any time soon, and hence any of the functions here are +;; explicitly likely to be obsoleted or moved elsewhere. +;; +;; Proceed with caution. +;; +;; +;; Bonzai Lab, LLC. All rights reserved. +;; +;; Licensed under LGPL. +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; main.ss - provide all other modules... +;; yc 9/8/2009 - first version +;; yc 9/11/2009 - added uuid.ss +;; yc 9/25/2009 - added assert.ss & move args.ss from port.plt +;; yc 10/13/2009 - adding bytes.ss +;; yc 10/19/2009 - adding require.ss & syntax.ss (it seems that all syntax-based files can be splitted away)... +;; yc 1/18/2010 - added version.ss & version-case.ss +(require "args.ss" + "assert.ss" + "base.ss" + "bytes.ss" + "list.ss" + "registry.ss" + "require.ss" + "syntax.ss" + "text.ss" + "uuid.ss" + "version.ss" + "version-case.ss" + ) +(provide (all-from-out "args.ss" + "assert.ss" + "base.ss" + "bytes.ss" + "list.ss" + "registry.ss" + "require.ss" + "syntax.ss" + "text.ss" + "uuid.ss" + "version.ss" + "version-case.ss" + )) diff --git a/ebus-racket/3rdparty/bzlib/base/registry.ss b/ebus-racket/3rdparty/bzlib/base/registry.ss new file mode 100644 index 0000000..d0b0c72 --- /dev/null +++ b/ebus-racket/3rdparty/bzlib/base/registry.ss @@ -0,0 +1,215 @@ +#lang scheme/base +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; BASE.plt - common routines that are shared by all other bzlib modules +;; +;; in a way, base.plt is the most fundamental module of the whole bzlib stack +;; and as such it also is the lowest level code. We are not likely to +;; fix the code any time soon, and hence any of the functions here are +;; explicitly likely to be obsoleted or moved elsewhere. +;; +;; Proceed with caution. +;; +;; +;; Bonzai Lab, LLC. All rights reserved. +;; +;; Licensed under LGPL. +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; registry.ss - generalized key/value access (including an extensible condition object) +;; yc 9/8/2009 - first version +;; yc 7/7/2010 - add registry-clear! & modified registry definition. +(require mzlib/pconvert-prop + scheme/port + scheme/string + scheme/contract + "base.ss" + ) +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; registry +;; a abstraction over key/value pairs + +(define-struct registry (get set del make (table #:mutable))) + +(define (registry-set! reg key val) + (set-registry-table! reg + ((registry-set reg) (registry-table reg) key val))) + +(define (registry-del! reg key) + (set-registry-table! reg + ((registry-del reg) (registry-table reg) key))) + +(define (registry-ref reg key (default #f)) + ((registry-get reg) (registry-table reg) key default)) +;; (trace registry-ref) + +(define (registry-clear! reg) ;; clearing the registry... we need to fill it with a default value, of course. + ;; that means we need a way to get the default value... does that mean we will have to empty out the whole value... + ;; is there a way to do so without adding a new field? + ;; it is completely unclear... hmm... + ;; a hash's function is make-hash... + ;; an immutable-hash's function is make-immutable-hash-helper... + ;; an assoc's function + (set-registry-table! reg ((registry-make reg)))) + + +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; make-hash-registry +(define (make-hash-registry (hash (make-hash))) + (define (set hash key val) + (hash-set! hash key val) + hash) + (define (del hash key) + (hash-remove! hash key) + hash) + (define (make (value (make-hash))) + (cond ((hash? value) value) + ((list? value) + (let ((h (make-hash))) + (for-each (lambda (kv) + (hash-set! h (car kv) (cdr kv))) + value) + h)) + (else (error 'make-hash-unknown-input "~a" value)))) + (make-registry hash-ref set del make (make hash))) + +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; make-immutable-hash-registry +(define (make-immutable-hash-registry (hash (make-immutable-hash '()))) + (define (make (value (make-immutable-hash '()))) + (cond ((and (immutable? value) (hash? value)) value) + ((hash? value) (make-immutable-hash (hash-map value cons))) + ((list? value) (make-immutable-hash value)) + (else (error 'make-immutable-hash-unknown-input "~a" value)))) + (make-registry hash-ref hash-set hash-remove make (make hash))) + +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; make-assoc-registry (not thread safe if multiple addition & deletion) +;; let's also a list registry via assoc. +(define (assoc-ref lst key (default #f)) + (define (assoc/cdr key value (default #f)) + (let ((value (assoc key value))) + (if (not value) default + (cdr value)))) + (assoc/cdr key lst default)) +;; (trace assoc-ref) +;; if we just want to remove the first guy with the key... how to do that? not with filter. + +(define (assoc-del lst key) + (define (helper k kv) + (equal? k (car kv))) + ;; (trace helper) + (remove key lst helper)) + +(define (assoc-set lst key val) + (let ((exists? #f)) + (let ((lst (map (lambda (kv) + (cons (car kv) + (cond ((equal? (car kv) key) + (set! exists? #t) + val) + (else (cdr kv))))) + lst))) + (if exists? lst + (cons (cons key val) lst))))) + +(define (make-list (lst '())) + (if (list? lst) + lst + (error 'make-assoc-list-unknown-input "~a" lst))) + +(define (make-assoc-registry (lst '())) + (make-registry assoc-ref assoc-set assoc-del make-list (make-list lst))) + +;; what can be passed into ? it must be a list of lists. +(define (list->assoc-registry lst) + (define (helper kvs) + (cons (car kvs) + (make-assoc-registry (cdr kvs)))) + ;; (trace helper) + (make-assoc-registry (map helper lst))) + +(define (assoc-registry->list reg) + (map (lambda (kv) + (cons (car kv) + (registry-table (cdr kv)))) + (registry-table reg))) + +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; cond-registry (takes in a cond & result pair). +(define (cond-ref lst key (default #f)) + (let ((it (assf (lambda (cond) + (cond key)) lst))) + (if (not it) default + (cdr it)))) + +(define (make-cond-registry (lst '())) + (make-registry cond-ref assoc-set assoc-del make-list (make-list lst))) + +(provide/contract + (struct registry ((get (->* (any/c any/c) + (any/c) + any)) + (set (-> any/c any/c any/c any)) + (del (-> any/c any/c any)) + (make (->* () + (any/c) + any/c)) + (table any/c))) + (registry-ref (->* (registry? any/c) + (any/c) + any)) + (registry-set! (-> registry? any/c any/c any)) + (registry-del! (-> registry? any/c any)) + (registry-clear! (-> registry? any)) + (make-hash-registry (->* () + ((or/c list? hash?)) + registry?)) + (make-immutable-hash-registry (->* () + ((or/c list? (and/c immutable? hash?))) + registry?)) + (assoc-ref (->* (list? any/c) + (any/c) + any)) + (assoc-set (-> list? any/c any/c any)) + (assoc-del (-> list? any/c any)) + (make-assoc-registry (->* () + (list?) + registry?)) + (list->assoc-registry (-> list? registry?)) + (assoc-registry->list (-> registry? list?)) + (make-cond-registry (->* () + (list?) + registry?)) + ) + +;; let's see how something can be flushed... +(define (registry->out reg out) + (write (registry-table reg) out)) + +(define (registry->string reg) + (let ((out (open-output-bytes))) + (registry->out reg out) + (get-output-string out))) + +(define (in->registry in) + (let ((value (read in))) + (cond ((list? value) + (make-assoc-registry value)) + ((and (hash? value) (immutable? value)) + (make-immutable-hash-registry value)) + ((hash? value) + (make-hash-registry value)) + ((eof-object? value) + (make-assoc-registry)) + (else + (error 'in->registry "unknown registry type ~a" value))))) + +(define (string->registry string) + (in->registry (open-input-string string))) + +(provide/contract + (registry->out (-> registry? output-port? any)) + (registry->string (-> registry? string?)) + (in->registry (-> input-port? registry?)) + (string->registry (-> string? registry?)) + ) + diff --git a/ebus-racket/3rdparty/bzlib/base/require.ss b/ebus-racket/3rdparty/bzlib/base/require.ss new file mode 100644 index 0000000..fced045 --- /dev/null +++ b/ebus-racket/3rdparty/bzlib/base/require.ss @@ -0,0 +1,32 @@ +#lang scheme/base +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; BASE.plt - common routines that are shared by all other bzlib modules +;; +;; in a way, base.plt is the most fundamental module of the whole bzlib stack +;; and as such it also is the lowest level code. We are not likely to +;; fix the code any time soon, and hence any of the functions here are +;; explicitly likely to be obsoleted or moved elsewhere. +;; +;; Proceed with caution. +;; +;; +;; Bonzai Lab, LLC. All rights reserved. +;; +;; Licensed under LGPL. +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; require.ss - require-like syntaxes +;; yc 10/19/2009 - first version +(require (for-syntax scheme/base "syntax.ss") + ) + +(define-syntax (provide/strip-prefix stx) + (syntax-case stx () + ((~ prefix out ...) + (with-syntax (((in ...) + (syntax-map (lambda (s) + (syntax-identifier-append #'prefix s)) + #'(out ...)))) + #'(provide (rename-out (in out) ...)))))) + +(provide provide/strip-prefix) + diff --git a/ebus-racket/3rdparty/bzlib/base/syntax.ss b/ebus-racket/3rdparty/bzlib/base/syntax.ss new file mode 100644 index 0000000..a5fbb27 --- /dev/null +++ b/ebus-racket/3rdparty/bzlib/base/syntax.ss @@ -0,0 +1,62 @@ +#lang scheme/base +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; BASE.plt - common routines that are shared by all other bzlib modules +;; +;; in a way, base.plt is the most fundamental module of the whole bzlib stack +;; and as such it also is the lowest level code. We are not likely to +;; fix the code any time soon, and hence any of the functions here are +;; explicitly likely to be obsoleted or moved elsewhere. +;; +;; Proceed with caution. +;; +;; +;; Bonzai Lab, LLC. All rights reserved. +;; +;; Licensed under LGPL. +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; synatx.ss - syntax helpers +;; yc 10/19/2009 - first version +;; yc 7/6/2010 - fixed syntax-identifier-append +(require (for-syntax scheme/base) + syntax/stx scheme/string mzlib/trace + scheme/contract + ) + +(define (syntax-map proc stx-lst) + (syntax-case stx-lst () + (() #'()) + ((id . rest) + #`(#,(proc #'id) . #,(syntax-map proc #'rest))))) + +(define (syntax-identifier-append arg #:stx (stx #f) . args) + (define (get-first-syntax lst) + (define (helper lst) + (cond ((null? lst) (error 'syntax-identifier-append "no stx for context")) + ((syntax? (car lst)) (car lst)) + (else (helper (cdr lst))))) + (if (not stx) (helper lst) stx)) + (define (->string x) + (cond ((syntax? x) (->string (syntax->datum x))) + (else (format "~a" x)))) + (define (helper args) + (datum->syntax (get-first-syntax args) + (string->symbol (string-join (map ->string args) "")))) + (helper (cons arg args))) + +(define (syntax-id-part? stx) + (define (helper part) + (or (symbol? part) (bytes? part) (string? part) (number? part))) + (or (and (syntax? stx) + (helper (syntax->datum stx))) + (helper stx))) + +(provide/contract + (syntax-map (-> (-> any/c any) stx-pair? any)) + (syntax-identifier-append (->* (syntax-id-part?) + (#:stx syntax?) + #:rest (listof syntax-id-part?) + syntax?)) + ) + +(provide (all-from-out syntax/stx)) + diff --git a/ebus-racket/3rdparty/bzlib/base/text.ss b/ebus-racket/3rdparty/bzlib/base/text.ss new file mode 100644 index 0000000..1185b17 --- /dev/null +++ b/ebus-racket/3rdparty/bzlib/base/text.ss @@ -0,0 +1,69 @@ +#lang scheme/base +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; BASE.plt - common routines that are shared by all other bzlib modules +;; +;; in a way, base.plt is the most fundamental module of the whole bzlib stack +;; and as such it also is the lowest level code. We are not likely to +;; fix the code any time soon, and hence any of the functions here are +;; explicitly likely to be obsoleted or moved elsewhere. +;; +;; Proceed with caution. +;; +;; +;; Bonzai Lab, LLC. All rights reserved. +;; +;; Licensed under LGPL. +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; text.ss - basic "text" (or string) service. +;; yc 9/8/2009 - first version +;; yc 2/1/2010 - adding the ability to extend the behavior of the string function... +(require "base.ss" + scheme/string + "registry.ss" + scheme/function + scheme/contract + ) + +(define default->string (curry format "~a")) + +(define string-converter-table (make-cond-registry '())) + +(define (string-converter-ref obj) + (registry-ref string-converter-table obj default->string)) + +(define (string-converter-set! type? converter) + (registry-set! string-converter-table type? converter)) + +(define (string-converter-del! type?) + (registry-del! string-converter-table type?));; + +(define (stringify* arg . args) + (stringify (cons arg args))) + +(define (any->string v) + (cond ((string? v) v) + (else + ((string-converter-ref v) v)))) + +(define (stringify args) + (string-join (map any->string args) "")) + +(provide/contract + (stringify* (->* (any/c) + () + #:rest (listof any/c) + string?)) + (stringify (-> (listof any/c) string?)) + ;;(string-converter-table registry?) + (string-converter-ref (-> any/c any)) + (string-converter-set! (-> procedure? procedure? any)) + (string-converter-del! (-> procedure? any)) + (any->string (-> any/c string?)) + (rename stringify* any*->string (->* (any/c) + () + #:rest (listof any/c) + string?)) + (rename stringify any/list->string (-> (listof any/c) string?)) + ) + +(provide (all-from-out scheme/string))
\ No newline at end of file diff --git a/ebus-racket/3rdparty/bzlib/base/uuid.ss b/ebus-racket/3rdparty/bzlib/base/uuid.ss new file mode 100644 index 0000000..d4cf293 --- /dev/null +++ b/ebus-racket/3rdparty/bzlib/base/uuid.ss @@ -0,0 +1,202 @@ +#lang scheme/base
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; BASE.plt - common routines that are shared by all other bzlib modules
+;;
+;; in a way, base.plt is the most fundamental module of the whole bzlib stack
+;; and as such it also is the lowest level code. We are not likely to
+;; fix the code any time soon, and hence any of the functions here are
+;; explicitly likely to be obsoleted or moved elsewhere.
+;;
+;; Proceed with caution.
+;;
+;;
+;; Bonzai Lab, LLC. All rights reserved.
+;;
+;; Licensed under LGPL.
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; uuid.ss - provide uuid object (currently wrapping over zitterbewegung/uuid-v4)
+;; yc 9/11/2009 - first version
+(require (prefix-in z: "../../zitterbewegung/uuid/uuid-v4.ss")
+ "base.ss"
+ scheme/list
+ scheme/string
+ scheme/contract
+ ;; (planet vyzo/crypto/util)
+ )
+
+(define (bytes->integer bytes)
+ (define (helper rest num)
+ (if (null? rest) num
+ (helper (cdr rest) (+ (* num 255) (car rest)))))
+ (helper (bytes->list bytes) 0))
+
+(define (bytes->hex bytes)
+ (define (helper rest acc)
+ (if (null? rest) (list->string (map hex-byte->char (reverse acc)))
+ (helper (cdr rest)
+ (let-values (((quotient remainder)
+ (quotient/remainder (car rest) 16)))
+ (list* remainder quotient acc)))))
+ (helper (bytes->list bytes) '()))
+
+;; *uuid structure - representing UUID, and holds bytes format...
+(define-struct *uuid (bytes)
+ #:property prop:custom-write
+ (lambda (u out write?)
+ (display (format "#<uuid:~a>" (uuid->string u)) out))
+ #:property prop:equal+hash
+ (list (lambda (u1 u2 sub?)
+ (bytes=? (*uuid-bytes u1) (*uuid-bytes u2)))
+ (lambda (u recur)
+ (bytes->integer (*uuid-bytes u)))
+ (lambda (u recur)
+ (bytes->integer (*uuid-bytes u)))))
+
+(define (uuid-time-low u)
+ (integer-bytes->integer (subbytes (*uuid-bytes u) 0 4) #f #t))
+
+(define (uuid-time-mid u)
+ (integer-bytes->integer (subbytes (*uuid-bytes u) 4 6) #f #t))
+
+(define (uuid-time-high u)
+ (integer-bytes->integer (subbytes (*uuid-bytes u) 6 8) #f #t))
+
+(define (uuid-clock-high u)
+ (integer-bytes->integer (bytes-append (list->bytes (list 0))
+ (subbytes (*uuid-bytes u) 8 9)) #f #t))
+
+(define (uuid-clock-low u)
+ (integer-bytes->integer (bytes-append (list->bytes (list 0))
+ (subbytes (*uuid-bytes u) 9 10)) #f #t))
+
+(define (uuid-node u)
+ (integer-bytes->integer (bytes-append (list->bytes (list 0 0))
+ (subbytes (*uuid-bytes u) 10 16)) #f #t))
+
+(define (uuid->string u (dash? #t))
+ (define (sub start end)
+ (subbytes (*uuid-bytes u) start end))
+ (if (not dash?)
+ (bytes->hex (*uuid-bytes u))
+ (string-join (map (lambda (b)
+ (bytes->hex b))
+ (list (sub 0 4) (sub 4 6) (sub 6 8) (sub 8 10) (sub 10 16)))
+ "-")))
+
+
+(define (uuid-string? u)
+ (and (string? u)
+ (regexp-match #px"^(?i:([0-9a-f]{,8})-?([0-9a-f]{,4})-?([0-9a-f]{,4})-?([0-9a-f]{,4})-?([0-9a-f]{,12}))$" u)))
+
+(define (uuid-symbol? u)
+ (and (symbol? u)
+ (uuid-string? (symbol->string u))))
+
+(define (uuid-bytes? u)
+ (and (bytes? u)
+ (= (bytes-length u) 16)))
+
+;; an uuid should be one of the following:
+;; struct of *uuid
+;; 16-bytes byte string.
+;; a string of 32 or 36 hex chars.
+(define (uuid? u)
+ (or (*uuid? u)
+ (uuid-bytes? u)
+ (uuid-string? u)))
+
+(define (make-uuid (u (symbol->string (z:make-uuid))))
+ (cond ((*uuid? u)
+ (make-*uuid (*uuid-bytes u)))
+ ((uuid-bytes? u)
+ (make-*uuid u))
+ (else
+ (uuid-string->uuid u))))
+
+(define (hex-byte->char h)
+ (case h
+ ((0) #\0)
+ ((1) #\1)
+ ((2) #\2)
+ ((3) #\3)
+ ((4) #\4)
+ ((5) #\5)
+ ((6) #\6)
+ ((7) #\7)
+ ((8) #\8)
+ ((9) #\9)
+ ((10) #\a)
+ ((11) #\b)
+ ((12) #\c)
+ ((13) #\d)
+ ((14) #\e)
+ ((15) #\f)
+ (else (error 'hex-byte->char "Not an hex byte: ~a" h))))
+
+(define (hex-char->integer c)
+ (case c
+ ((#\1) 1)
+ ((#\2) 2)
+ ((#\3) 3)
+ ((#\4) 4)
+ ((#\5) 5)
+ ((#\6) 6)
+ ((#\7) 7)
+ ((#\8) 8)
+ ((#\9) 9)
+ ((#\0) 0)
+ ((#\a #\A) 10)
+ ((#\b #\B) 11)
+ ((#\c #\C) 12)
+ ((#\d #\D) 13)
+ ((#\e #\E) 14)
+ ((#\f #\F) 15)
+ (else (error 'hex-char->integer "char ~a out of range" c))))
+
+(define (hex-char? c)
+ (member c '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\a #\A #\b #\B #\c #\C #\d #\D #\e #\E #\f #\F)))
+
+(define (hex-chars->byte chars)
+ (define (helper rest num)
+ (if (null? rest)
+ num
+ (helper (cdr rest) (+ (* 16 num) (hex-char->integer (car rest))))))
+ (helper chars 0))
+
+(define (hex-string->bytes h)
+ (define (helper rest acc)
+ (cond ((null? rest) (reverse acc))
+ ((null? (cdr rest)) ;; wrong
+ (error 'hex-string->bytes "Uneven # of hexdecimal strings: ~a" h))
+ (else
+ (helper (cddr rest)
+ (cons (hex-chars->byte (list (car rest) (cadr rest)))
+ acc)))))
+ (helper (string->list h) '()))
+
+(define (uuid-string->uuid uuid)
+ (make-*uuid (list->bytes (flatten (map hex-string->bytes (cdr (uuid-string? uuid)))))))
+
+;; how quickly can all the generation take?
+;; it seems that
+(provide/contract
+ (make-uuid (->* ()
+ (uuid?)
+ *uuid?))
+ (uuid->string (->* (*uuid?)
+ (boolean?)
+ string?))
+ (rename *uuid-bytes uuid->bytes (-> *uuid? bytes?))
+ (uuid-string? (-> any/c any))
+ (uuid-bytes? (-> any/c any))
+ (uuid-time-low (-> *uuid? number?))
+ (uuid-time-mid (-> *uuid? number?))
+ (uuid-time-high (-> *uuid? number?))
+ (uuid-clock-low (-> *uuid? number?))
+ (uuid-clock-high (-> *uuid? number?))
+ (uuid-node (-> *uuid? number?))
+ (uuid? (-> any/c any))
+ (bytes->hex (-> bytes? string?))
+ (bytes->integer (-> bytes? number?))
+ )
+
diff --git a/ebus-racket/3rdparty/bzlib/base/version-case.ss b/ebus-racket/3rdparty/bzlib/base/version-case.ss new file mode 100644 index 0000000..a9f60d7 --- /dev/null +++ b/ebus-racket/3rdparty/bzlib/base/version-case.ss @@ -0,0 +1,118 @@ +#lang scheme/base +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; BASE.plt - common routines that are shared by all other bzlib modules +;; +;; in a way, base.plt is the most fundamental module of the whole bzlib stack +;; and as such it also is the lowest level code. We are not likely to +;; fix the code any time soon, and hence any of the functions here are +;; explicitly likely to be obsoleted or moved elsewhere. +;; +;; Proceed with caution. +;; +;; +;; Bonzai Lab, LLC. All rights reserved. +;; +;; Licensed under LGPL. +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; version-case.ss - version-based macros +;; yc 1/18/2010 - first version +(require (for-syntax scheme/base + "version.ss" + ) + "version.ss" + ) + +(define-syntax (+:version stx) + (syntax-case stx (between > >= < <= = != else) + ((~) #'(void)) + ((~ (else exp)) #'exp) + ((~ ((between min max) exp) rest ...) + (version<=? (syntax->datum #'min) + (version) + (syntax->datum #'max)) + #'exp) + ((~ ((between min max) exp) rest ...) + #'(~ rest ...)) + ((~ ((> v) exp) rest ...) + (version>? (version) (syntax->datum #'v)) + #'exp) + ((~ ((> v) exp) rest ...) + #'(~ rest ...)) + ((~ ((>= v) exp) rest ...) + (version>=? (version) (syntax->datum #'v)) + #'exp) + ((~ ((>= v) exp) rest ...) + #'(~ rest ...)) + ((~ ((< v) exp) rest ...) + (version<? (version) (syntax->datum #'v)) + #'exp) + ((~ ((< v) exp) rest ...) + #'(~ rest ...)) + ((~ ((<= v) exp) rest ...) + (version<=? (version) (syntax->datum #'v)) + #'exp) + ((~ ((<= v) exp) rest ...) + #'(~ rest ...)) + ((~ ((= v) exp) rest ...) + (version=? (version) (syntax->datum #'v)) + #'exp) + ((~ ((= v) exp) rest ...) + #'(~ rest ...)) + ((~ ((!= v) exp) rest ...) + (version!=? (version) (syntax->datum #'v)) + #'exp) + ((~ ((!= v) exp) rest ...) + #'(~ rest ...)) + )) + +(define-syntax +:version-between + (syntax-rules () + ((~ min max exp otherwise) + (+:version ((between min max) exp) (else otherwise))) + )) + +(define-syntax define-version-if + (syntax-rules () + ((~ name comp) + (define-syntax name + (syntax-rules () + ((~ v exp otherwise) + (+:version ((comp v) exp) (else otherwise)))))) + )) + +(define-version-if +:version> >) + +(define-version-if +:version>= >=) + +(define-version-if +:version< <) + +(define-version-if +:version<= <=) + +(define-version-if +:version= =) + +(define-version-if +:version!= !=) + +(define-syntax require/v + (syntax-rules () + ((~ (test s1 ...) ...) + (+:version (test (require s1 ...)) ...)) + )) + +(define-syntax provide/v + (syntax-rules () + ((~ (test s1 ...) ...) + (+:version (test (provide s1 ...)) ...)) + )) + +(provide +:version + +:version-between + +:version> + +:version>= + +:version< + +:version<= + +:version= + +:version!= + require/v + provide/v + ) + diff --git a/ebus-racket/3rdparty/bzlib/base/version.ss b/ebus-racket/3rdparty/bzlib/base/version.ss new file mode 100644 index 0000000..0932012 --- /dev/null +++ b/ebus-racket/3rdparty/bzlib/base/version.ss @@ -0,0 +1,71 @@ +#lang scheme/base +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; BASE.plt - common routines that are shared by all other bzlib modules +;; +;; in a way, base.plt is the most fundamental module of the whole bzlib stack +;; and as such it also is the lowest level code. We are not likely to +;; fix the code any time soon, and hence any of the functions here are +;; explicitly likely to be obsoleted or moved elsewhere. +;; +;; Proceed with caution. +;; +;; +;; Bonzai Lab, LLC. All rights reserved. +;; +;; Licensed under LGPL. +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; version.ss - version comparison utilities as well as version-based macros +;; yc 1/18/2010 - first version +(require (prefix-in v: version/utils) + scheme/contract + (for-syntax scheme/base + (prefix-in v: version/utils)) + mzlib/trace + ) + +(define (version? v) + (and (string? v) + (integer? (v:version->integer v)))) + +(define (vcomp? comp? v v2 vs) + (apply comp? (map v:version->integer (list* v v2 vs)))) + +(define (version<? v v2 . vs) + (vcomp? < v v2 vs)) +;; (trace version<?) + +(define (version<=? v v2 . vs) + (vcomp? <= v v2 vs)) +;; (trace version<=?) + +(define (version>=? v v2 . vs) + (vcomp? >= v v2 vs)) +;; (trace version>=?) + +(define (version>? v v2 . vs) + (vcomp? > v v2 vs)) +;; (trace version>?) + +(define (version=? v v2 . vs) + (vcomp? = v v2 vs)) +;; (trace version=?) + +(define (version!=? v v2 . vs) + (vcomp? (compose not =) v v2 vs)) +;; (trace version!=?) + +(define vcomp/c (->* (version? version?) + () + #:rest (listof version?) + boolean?)) + +(provide/contract + (version? (-> any/c boolean?)) + (version<? vcomp/c) + (version<=? vcomp/c) + (version>=? vcomp/c) + (version>? vcomp/c) + (version=? vcomp/c) + (version!=? vcomp/c) + ) + diff --git a/ebus-racket/3rdparty/bzlib/parseq/basic.ss b/ebus-racket/3rdparty/bzlib/parseq/basic.ss new file mode 100644 index 0000000..4e5d94a --- /dev/null +++ b/ebus-racket/3rdparty/bzlib/parseq/basic.ss @@ -0,0 +1,200 @@ +#lang scheme/base +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; PARSEQ.PLT +;; A Parser Combinator library. +;; +;; Bonzai Lab, LLC. All rights reserved. +;; +;; Licensed under LGPL. +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; basic.ss - a set of basic parsers +;; yc 12/31/2009 - first version +;; yc 7/7/2010 - updating real-number to also handle exponents. + +(require "depend.ss" + "primitive.ss" + "combinator.ss" + "input.ss" + ) + +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; char parsers. +;; digit +(define digit (char-between #\0 #\9)) + +;; not-digit +(define not-digit (char-not-between #\0 #\9)) + +;; lower-case +(define lower-case (char-between #\a #\z)) + +;; upper-case +(define upper-case (char-between #\A #\Z)) + +;; alpha +(define alpha (choice lower-case upper-case)) + +;; alphanumeric +(define alphanumeric (choice alpha digit)) + +;; hexdecimal parser +(define hexdecimal (char-in '(#\a #\b #\c #\d #\e #\f + #\A #\B #\C #\D #\E #\F + #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9))) + +;; whitespace +(define whitespace (char-in '(#\space #\return #\newline #\tab #\vtab))) + +(define not-whitespace (char-not-in '(#\space #\return #\newline #\tab #\vtab))) + +;; ascii +(define ascii (char-between (integer->char 0) (integer->char 127))) + +;; word = a-zA-Z0-9_ +(define word (choice alphanumeric (char= #\_))) + +;; not-word +(define not-word (char-when (lambda (c) + (not (or (char<=? #\a c #\z) + (char<=? #\A c #\Z) + (char<=? #\0 c #\9) + (char=? c #\_)))))) + +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; number parsers. + +;; signed +(define sign (zero-one (char= #\-) #\+)) + +;; natural +(define natural (one-many digit)) + +;; decimal +;; there is a bug - anything fails in seq should automatically fail the whole thing... +(define decimal (seq number <- (zero-many digit) + point <- (char= #\.) + decimals <- natural + (return (append number (cons point decimals))))) + +(define (hexdecimals->number hexes) + (define (hex->num hex) + (- (char->integer hex) + (char->integer (case hex + ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) #\0) + ((#\a #\b #\c #\d #\e #\f) #\a) + ((#\A #\B #\C #\D #\E #\F) #\A))) + (- (case hex + ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) 0) + ((#\a #\b #\c #\d #\e #\f) 10) + ((#\A #\B #\C #\D #\E #\F) 10))))) + (define (helper rest total) + (if (null? rest) + total + (helper (cdr rest) (+ (hex->num (car rest)) (* total 16))))) + ;;(trace helper) + ;;(trace hex->num) + (helper hexes 0)) + +(define hexdecimals (seq num <- (zero-many hexdecimal) + (return (hexdecimals->number num)))) + +;; positive +(define positive (choice decimal natural)) + +;; signed (number) +(define (make-signed parser) + (seq +/- <- sign + number <- parser + (return (cons +/- number)))) + +;; make-number +(define (make-number parser) + (seq n <- parser + (return (string->number (list->string n))))) + +;; natural-number +(define natural-number (make-number natural)) + +;; integer +(define integer (make-number (make-signed natural))) + +;; positive-integer +(define positive-number (make-number positive)) + +;; real-number (now handling exponents) +(define real-number (make-number (choice (seq exp <- (make-signed positive) + e <- (choice #\E #\e) + magenta <- (make-signed natural) + (return (append exp (list e) magenta))) + (make-signed positive) + ))) + +(define hexdecimal-number (make-number hexdecimals)) + +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; string parsers. + +;; escaped-char +;; allows for an escaping sequence for a particular character... +(define (escaped-char escape char (as #f)) + (seq (char= escape) + c <- (if (char? char) (char= char) char) + (return (if as as c)))) + +;; e-newline +(define e-newline (escaped-char #\\ #\n #\newline)) + +;; e-return +(define e-return (escaped-char #\\ #\r #\return)) + +;; e-tab +(define e-tab (escaped-char #\\ #\t #\tab)) + +;; e-backslash +(define e-backslash (escaped-char #\\ #\\)) + +;; quoted +;; a specific string-based bracket parser +(define (quoted open close escape) + (seq (char= open) + atoms <- (zero-many (choice e-newline + e-return + e-tab + e-backslash + (escaped-char escape close) + (char-not-in (list close #\\)))) + (char= close) + (return atoms))) + +;; make-quoted-string +;; a simplification for creating a string parser +(define (make-quoted-string open (close #f) (escape #\\)) + (seq v <- (quoted open (if close close open) escape) + (return (list->string v)))) + +;; single-quoted-string +;; parse a string with single quotes +(define single-quoted-string (make-quoted-string #\')) + +;; double-quoted-string +;; parse a string with double quotes +(define double-quoted-string (make-quoted-string #\")) + +;; quoted-string +;; choosing between single and double quotes +(define quoted-string + (choice single-quoted-string double-quoted-string)) + +;; whitespaces +;; parsing out all whitespaces together... +(define whitespaces (zero-many whitespace)) + +;; newline +(define newline + (choice (seq r <- (char= #\return) + n <- (char= #\newline) + (return (list r n))) + (char= #\return) + (char= #\newline))) + +(provide (all-defined-out)) diff --git a/ebus-racket/3rdparty/bzlib/parseq/combinator.ss b/ebus-racket/3rdparty/bzlib/parseq/combinator.ss new file mode 100644 index 0000000..b68764d --- /dev/null +++ b/ebus-racket/3rdparty/bzlib/parseq/combinator.ss @@ -0,0 +1,208 @@ +#lang scheme/base +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; PARSEQ.PLT +;; A Parser Combinator library. +;; +;; Bonzai Lab, LLC. All rights reserved. +;; +;; Licensed under LGPL. +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; combinator.ss - higher level combinator for parsers... +;; yc 12/31/2009 - first version +;; yc 1/5/2010 - moved delimited, bracket, and alternate to token.ss +(require "depend.ss" + mzlib/defmacro + (for-syntax scheme/base + "depend.ss" + scheme/match + ) + "primitive.ss" + "input.ss" + ) + +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Parser COMBINATORS + +;; bind +;; Parser a -> (a -> Parser b) -> Parser b +;; this is the function version of the monad - use this when you want to +;; create higher combinators dynamically... +(define (bind parser v->parser) + (lambda (in) + (let-values (((v in) + (parser in))) + ((v->parser v) in)))) + +;; result +;; allows the transformation of the result of the parser... +(define (result parser transform) + (bind parser + (lambda (v) + (if (succeeded? v) + (return (transform v)) + fail)))) + +(define (result* parser transform) + (bind parser + (lambda (v) + (if (and (succeeded? v) (list? v)) + (return (apply transform v)) + fail)))) + +;; seq +;; the macro-based monad for stringing multiple parsers together... +;; (seq parser) => parser +;; (seq v <- parser exp ...) => (bind paser (lambda (v) (if v (seq exp ...) fail)) +(define-macro (seq . exps) + (define *in (gensym 'in)) ;; represents the input + (define *v (gensym 'v)) ;; represents the value + (define literal 'literal) + ;; sequence body for creating a sequence combinator... + (define (body exps) + (match exps + ((list exp) + `((,literal ,exp) ,*in)) + ((list-rest var '<- exp rest) + `(let-values (((,var ,*in) + ((,literal ,exp) ,*in))) + (if (succeeded? ,var) + ,(body rest) + (fail in)))) + ((list-rest exp rest) + (body `(,*v <- ,exp . ,rest))) + )) + `(lambda (in) + (let ((,*in in)) + ,(body exps)))) + +;; sequence +;; a functional version of seq +(define (sequence parsers) + (lambda (IN) + (define (helper parsers in acc) + (if (null? parsers) + ((return (reverse acc)) in) + (let-values (((v in) + ((car parsers) in))) + (if (succeeded? v) + (helper (cdr parsers) in (cons v acc)) + (fail IN))))) + (helper (map literal parsers) IN '()))) + +;; sequence* +(define (sequence* . parsers) + (sequence parsers)) + +;; #| +;; choice +;; (choice parser) => (bind parser (lambda (v) (if v (return v) fail)) +;; (choice parser rest ...) => (bind parser (lambda (v) (if v (choice rest ...) fail))) +(define-macro (choice . exps) + (define *in (gensym 'in)) ;; represents the input + (define *v (gensym 'v)) ;; represents the value + (define (body exps) + (match exps + ((list) + `(fail ,*in)) + ((list-rest exp rest) + `(let-values (((,*v ,*in) + ((literal ,exp) ,*in))) + (if (succeeded? ,*v) + ((return ,*v) ,*in) + ,(body rest)))) + )) + `(lambda (,*in) + ,(body exps))) +;;|# + +;; one-of +;; a function version of choice +(define (one-of parsers) + (lambda (in) + (define (helper parsers) + (if (null? parsers) + (fail in) + (let-values (((v in) + ((car parsers) in))) + (if (succeeded? v) + ((return v) in) + (helper (cdr parsers)))))) + (helper (map literal parsers)))) + +;; one-of* +(define (one-of* . parsers) + (one-of parsers)) + +;; all-of +(define (all-of parsers) + (lambda (in) + (define (helper parsers v) + (if (null? parsers) + ((return v) in) + (let-values (((v IN) + ((car parsers) in))) + (if (succeeded? v) + (helper (cdr parsers) v) + (fail in))))) + (helper (map literal parsers) (make-failed 0)))) + +;; all-of* +(define (all-of* . parsers) + (all-of parsers)) + +;; repeat +;; returns when # of occurence falls within the min and max range +;; default to [1,+inf] +(define (repeat parser (min 1) (max +inf.0)) + (define (make parser) + (lambda (IN) + (define (helper prev-in acc count) + (let-values (((v in) + (parser prev-in))) + (if (succeeded? v) + (if (< count max) + (helper in (cons v acc) (add1 count)) + ((return (reverse acc)) prev-in)) + (if (< count min) + (fail IN) + ((return (reverse acc)) in))))) + (helper IN '() 0))) + (make (literal parser))) + +;; zero-many +;; returns the matched values if zero or more matches +;; (this means that this parser will always match) +(define (zero-many parser) + (repeat parser 0)) + +;; one-many +;; matches if parser parses one or more times +(define (one-many parser) + (repeat parser)) + +;; zero-one +;; returns if the parser matches zero or one times +;; when the parser does not match, it defaults to fail, but you can pass in a +;; default value so it does not fail. +(define (zero-one parser default) + (lambda (in) + (let-values (((v in) + ((literal parser) in))) + ((return (if (succeeded? v) v default)) in)))) + +(provide bind + result + result* + seq + sequence + sequence* + choice + one-of + one-of* + all-of + all-of* + repeat + zero-many + one-many + zero-one + ) diff --git a/ebus-racket/3rdparty/bzlib/parseq/depend.ss b/ebus-racket/3rdparty/bzlib/parseq/depend.ss new file mode 100644 index 0000000..03737ad --- /dev/null +++ b/ebus-racket/3rdparty/bzlib/parseq/depend.ss @@ -0,0 +1,3 @@ +#lang scheme +(require "../base/main.ss") +(provide (all-from-out "../base/main.ss")) diff --git a/ebus-racket/3rdparty/bzlib/parseq/example/calc.ss b/ebus-racket/3rdparty/bzlib/parseq/example/calc.ss new file mode 100644 index 0000000..35ada60 --- /dev/null +++ b/ebus-racket/3rdparty/bzlib/parseq/example/calc.ss @@ -0,0 +1,51 @@ +#lang scheme/base +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; PARSEQ.PLT +;; A Parser Combinator library. +;; +;; Bonzai Lab, LLC. All rights reserved. +;; +;; Licensed under LGPL. +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; calc.ss - a simple arithmetic calculator +;; yc 12/31/2009 - first version +(require "../main.ss" + ) + +;; determine the operator (currently there are no precedences)... +(define OP (tokens op <- (char-in '(#\+ #\- #\* #\/)) + (return (case op + ((#\+) +) + ((#\-) -) + ((#\*) *) + ((#\/) /))))) + +(define NUMBER (token real-number)) + +;; expr := term op term +(define expr (tokens lhs <- term + (let loop ((lhs lhs)) + (choice (tokens opr <- OP + rhs <- term + (loop (list opr lhs rhs))) + (return lhs))))) +;; term := factor op factor +(define term (tokens lhs <- factor + (let loop ((lhs lhs)) + (choice (tokens opr <- OP + rhs <- factor + (loop (list opr lhs rhs))) + (return lhs))))) + +;; factor := number | ( exp ) +(define factor (choice NUMBER (bracket #\( expr #\)))) + +(define (calc in) + (define (helper exp) + (cond ((number? exp) exp) + ((pair? exp) + (apply (car exp) + (map helper (cdr exp)))))) + (helper ((make-reader expr) in))) + +(provide calc) diff --git a/ebus-racket/3rdparty/bzlib/parseq/example/csv.ss b/ebus-racket/3rdparty/bzlib/parseq/example/csv.ss new file mode 100644 index 0000000..4fd1526 --- /dev/null +++ b/ebus-racket/3rdparty/bzlib/parseq/example/csv.ss @@ -0,0 +1,42 @@ +#lang scheme/base +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; PARSEQ.PLT +;; A Parser Combinator library. +;; +;; Bonzai Lab, LLC. All rights reserved. +;; +;; Licensed under LGPL. +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; csv.ss - a customizable csv reader +;; yc 12/31/2009 - first version +(require "../main.ss" + ) + +;; creating a delimiter-based string. +(define (delim-string delim) + (seq s <- (zero-many (choice (escaped-char #\\ delim) + (char-not-in (list delim #\return #\newline)))) + (return (list->string s)))) + +;; csv-string +;; combine between quoted string and delimited string +(define (csv-string delim) + (choice quoted-string (delim-string delim))) + +;; csv-record +;; reads a list of csv-strings by skipping over the delimiters +(define (csv-record delim) + (delimited (csv-string delim) (char= delim))) + +;; csv-table +;; reads over a csv-table +(define (csv-table delim) + (delimited (csv-record delim) newline)) + +;; make-csv-reader +;; creates a csv-reader based on the delim... +(define (make-csv-reader delim) + (make-reader (csv-table delim))) + +;; contract +(provide make-csv-reader) diff --git a/ebus-racket/3rdparty/bzlib/parseq/example/json.ss b/ebus-racket/3rdparty/bzlib/parseq/example/json.ss new file mode 100644 index 0000000..c8df746 --- /dev/null +++ b/ebus-racket/3rdparty/bzlib/parseq/example/json.ss @@ -0,0 +1,135 @@ +#lang scheme/base +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; PARSEQ.PLT +;; A Parser Combinator library. +;; +;; Bonzai Lab, LLC. All rights reserved. +;; +;; Licensed under LGPL. +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; json.ss - a parser for the json format +;; yc 1/5/2010 - first version +;; yc 7/76/2010 - updated json-string to handle single quotes. +(require "../main.ss" + ) + +(define hex-digit (seq d <- (choice digit #\a #\b #\c #\d #\e #\f + #\A #\B #\C #\D #\E #\F) + (return (case d + ((#\0) 0) + ((#\1) 1) + ((#\2) 2) + ((#\3) 3) + ((#\4) 4) + ((#\5) 5) + ((#\6) 6) + ((#\7) 7) + ((#\8) 8) + ((#\9) 9) + ((#\a #\A) 10) + ((#\b #\B) 11) + ((#\c #\C) 12) + ((#\d #\D) 13) + ((#\e #\E) 14) + ((#\f #\F) 15))))) + +(define (hex->char h) + (case h + ((0) #\0) + ((1) #\1) + ((2) #\2) + ((3) #\3) + ((4) #\4) + ((5) #\5) + ((6) #\6) + ((7) #\7) + ((8) #\8) + ((9) #\9) + ((10) #\a) + ((11) #\b) + ((12) #\c) + ((13) #\d) + ((14) #\e) + ((15) #\f))) + + +(define (hexes->char hexes) + (integer->char (hexes->integer hexes))) + +(define (char->hexes c) + (integer->hexes (char->integer c))) + +(define (char->hex-chars c) + (map hex->char (char->hexes c))) + +(define (hexes->integer hexes) + (define (helper rest acc) + (cond ((null? rest) acc) + (else + (helper (cdr rest) (+ (* acc 16) (car rest)))))) + (helper hexes 0)) + +(define (integer->hexes i) + (define (helper q acc) + (if (= q 0) + acc + (let-values (((q r) + (quotient/remainder q 16))) + (helper q (cons r acc))))) + (helper i '())) + +(define unicode-char + (seq #\\ #\u + code <- (repeat hex-digit 4 4) + (return (hexes->char code)))) + +(define (json-string/inner quote) + (zero-many (choice e-newline + e-return + e-tab + e-backslash + (escaped-char #\\ quote) + (escaped-char #\\ #\/) + (escaped-char #\\ #\\) + (escaped-char #\\ #\b #\backspace) + (escaped-char #\\ #\f #\page) + unicode-char + (char-not-in (list quote + #\newline + #\return + #\tab + #\\ + #\backspace + #\page)) + ))) + +(define json-string + (choice (seq #\' atoms <- (json-string/inner #\') #\' + (return (list->string atoms))) + (seq #\" atoms <- (json-string/inner #\") #\" + (return (list->string atoms))))) + +(define json-array (tokens v <- (bracket/delimited #\[ json-value #\, #\]) + (return (list->vector v)))) + +(define json-object (tokens v <- (bracket/delimited #\{ json-pair #\, #\}) + (return (make-immutable-hash v)))) + +(define json-pair (tokens key <- (choice json-string + (seq c <- alpha + lst <- (zero-many alphanumeric) + (return (list->string (cons c lst))))) + #\: + value <- json-value + (return (cons key value)))) + +(define json-literal (choice (tokens "true" (return #t)) + (tokens "false" (return #f)) + (tokens "null" (return '())) + )) + +(define json-value (choice json-literal json-array json-object real-number json-string)) + +(define read-json (make-reader json-value)) + +(provide read-json) diff --git a/ebus-racket/3rdparty/bzlib/parseq/example/regex.ss b/ebus-racket/3rdparty/bzlib/parseq/example/regex.ss new file mode 100644 index 0000000..299b999 --- /dev/null +++ b/ebus-racket/3rdparty/bzlib/parseq/example/regex.ss @@ -0,0 +1,163 @@ +#lang scheme/base +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; PARSEQ.PLT +;; A Parser Combinator library. +;; +;; Bonzai Lab, LLC. All rights reserved. +;; +;; Licensed under LGPL. +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; regex.ss - a simple regular expression parser +;; yc 1/1/2009 - first version +(require "../main.ss" + mzlib/trace + ) + +;; sof = start of file +(define regex-sof (zero-one (char= #\^) #\$)) + +;; eof = end of file +(define regex-eof (zero-one (char= #\$) #\^)) + +;; meta-chars - a list of meta characters +(define regex-meta-chars '( #\. #\+ #\* #\? #\^ #\$ #\[ #\] #\( #\) #\{ #\} #\\)) + +;; digit = \\d +(define regex-digit (seq "\\d" (return digit))) + +;; not-digit = \\D +(define regex-not-digit (seq "\\D" (return not-digit))) + +;; word = \\w +(define regex-word (seq "\\w" (return word))) + +;; not-word = \\W +(define regex-not-word (seq "\\W" (return not-word))) + +;; whitespace = \\s +(define regex-whitespace (seq "\\s" (return whitespace))) + +;; not-whitespace = \\S +(define regex-not-whitespace (seq "\\S" (return not-whitespace))) + +;; any-char = . +(define regex-any-char (seq #\. (return any-char))) + +;; literal = \\d | \\D | \\w | \\W | \\s | \\S | . | \n | \r | \t | \\ | other chars +(define regex-literal (choice regex-digit + regex-not-digit + regex-word + regex-not-word + regex-whitespace + regex-not-whitespace + regex-any-char + (seq v <- (choice e-newline + e-return + e-tab + (escaped-char #\\ any-char) + (char-not-in regex-meta-chars)) + (return (char= v))))) + +;; atom = literal | group | choice +(define regex-atom (choice regex-literal + regex-group + regex-choice + )) + +;; char-range = <lc>-<hc>, e.g., a-z +(define regex-char-range (seq lc <- (char-not-in (cons #\- regex-meta-chars)) + #\- + hc <- (char-not-in (cons #\- regex-meta-chars)) + (return `(,char-between ,lc ,hc)))) + +;; choice = [<char-range | literal>+] +(define regex-choice (seq #\[ + literals <- (one-many (choice regex-char-range + regex-literal)) + #\] + (return `(,one-of* ,@literals)))) + +;; group = (<atom>+) +(define regex-group (seq #\( + chars <- (one-many regex-atom) + #\) + (return `(,sequence* ,@chars)))) + +;; regex combinators +;; zero-one = <atom>? +(define regex-zero-one (seq v <- regex-atom + #\? + (return `(,zero-one ,v)))) +;; zero-many = <atom>* +(define regex-zero-many (seq v <- regex-atom + #\* + (return `(,zero-many ,v)))) + +;; one-many = <atom>+ +(define regex-one-many (seq v <- regex-atom + #\+ + (return `(,one-many ,v)))) + +;; range = <atom>{min,max} | <atom>{times} +(define regex-range (seq v <- regex-atom + #\{ + min <- (zero-one natural-number 0) + max <- (zero-one (seq #\, + max <- (zero-one natural-number +inf.0) + (return max)) + min) + #\} + (return `(,repeat ,v ,min ,max)))) + +;; exp = sof ? <zero-one | zero-many | one-many | range | atom>* eof ? +(define regex-exp (seq SOF + sof <- regex-sof + atoms <- (zero-many (choice regex-zero-one + regex-zero-many + regex-one-many + regex-range + regex-atom + )) + eof <- regex-eof + EOF + (return `(,regex-parser* ,@(if (char=? sof #\^) + `(,SOF) + '()) + ,@atoms + ,@(if (char=? eof #\$) + `(,EOF) + '()))))) + +;; regex-parser +;; convert the regexp into an useable parser, which including determining +;; whether to allow for +(define (regex-parser parsers) + (let ((regexp (sequence parsers))) + (if (eq? (car parsers) SOF) + regexp + (seq v <- (choice regexp + (seq any-char (regex-parser parsers))) + (return v))))) + +;; regex-parser* +;; the variable arg form of regex-parser +(define (regex-parser* parser . parsers) + (regex-parser (cons parser parsers))) + +;; make-regex-exp +;; wrapper over regex... +(define (make-regex-exp in) + (define (helper exp) + (cond ((list? exp) (apply (car exp) (map helper (cdr exp)))) + (else exp))) + ;; (trace helper) + (let-values (((exp in) + (regex-exp (make-input in)))) + (if (failed? exp) + (error 'make-regex-exp "the regular expression is invalid") + (lambda (in) + ((helper exp) (make-input in)))))) + +(provide regex-parser + make-regex-exp + ) diff --git a/ebus-racket/3rdparty/bzlib/parseq/example/sql.ss b/ebus-racket/3rdparty/bzlib/parseq/example/sql.ss new file mode 100644 index 0000000..3863ab1 --- /dev/null +++ b/ebus-racket/3rdparty/bzlib/parseq/example/sql.ss @@ -0,0 +1,138 @@ +#lang scheme +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; PARSEQ.PLT +;; A Parser Combinator library. +;; +;; Bonzai Lab, LLC. All rights reserved. +;; +;; Licensed under LGPL. +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; sql.ss - parsing the create table statement +;; yc 1/5/2010 - first version +(require "../main.ss" + mzlib/defmacro + (for-syntax scheme/base + scheme/match + ) + (planet bzlib/base) + ) + +(define sql-identifier + (seq c <- alpha + rest <- (zero-many word) + (return (string->symbol + (string-downcase (list->string (cons c rest))))))) + +(define create-table-def + (tokens-ci "create" "table" + name <- sql-identifier + clauses <- (bracket #\( + (delimited clause-def #\,) + #\)) + (return (cons name clauses)))) + +(define clause-def + (choice primary-key-def foreign-key-def column-def)) + +;; making things without order would be quite a difficult combinator. +;; basically we need to try each of the combinator, and then as we have the binding +;; make sure it is returned in a way that can easily be identified... +;; for example, the first +(define (self-and-value parser) + (seq v <- parser + (return (cons parser v)))) + +(define (one-of-each parsers defaults) + ;; we need to try each one, and then figure out the *rest* that weren't matched + ;; continue until we are either out of the stream or out of the combinator... + ;; at any time there is anything that none of them matches then we will be in trouble... + (define (each-helper parsers) + (one-of (map self-and-value parsers))) + (define (sort-helper acc parsers defaults) + (map (lambda (v default) + (if (pair? v) + (cdr v) + default)) + (map (lambda (parser) + (assf (lambda (p) + (eq? p parser)) + acc)) + parsers) + defaults)) + ;; if all of them failed @ the next position, then we need to offer + ;; default values for the remainder of the parsers!!! + ;; this is where it is *interesting!!!... + ;; in such case we want to have a chance to work on the *fail* clause... + ;; this is hmm.... + (define (helper rest acc) + (bind (each-helper rest) + (lambda (v) + (if (succeeded? v) + (let ((rest (remove (car v) rest))) + (if (null? rest) + (return (sort-helper acc parsers defaults)) + (helper rest (cons v acc)))) + (return (sort-helper acc parsers defaults)))))) + (helper parsers '())) + +(define-syntax one-of-each* + (syntax-rules () + ((~ (parser default) ...) + (one-of-each (list parser ...) (list default ...))))) + +(define column-def + (tokens name <- sql-identifier + attrs <- (one-of-each* (type-def 'text) + (nullability 'null) + (inline-primary-key #f) + (inline-foreign-key #f)) + (return (cons name attrs)))) + +(define nullability + (choice (tokens-ci "null" (return 'null)) + (tokens-ci "not" "null" (return 'not-null)))) + +(define type-def + (seq type <- (choice (string-ci= "int") + (string-ci= "integer") + (string-ci= "float") + (string-ci= "text")) + (return (string->symbol type)))) + +(define inline-primary-key + (tokens-ci "primary" "key" (return 'pkey))) +;; (trace inline-primary-key) + +(define sql-identifiers/paren + (bracket #\( (delimited sql-identifier #\,) #\))) + +(define inline-foreign-key + (tokens-ci "foreign" "key" + (zero-one (string-ci= "references") "references") + table <- sql-identifier + (zero-one (string-ci= "on") "on") + columns <- sql-identifiers/paren + (return `(foreign-key ,table ,columns)))) + +(define primary-key-def + (tokens-ci "primary" "key" + name <- (zero-one sql-identifier #f) + columns <- sql-identifiers/paren + (return `(primary-key ,name ,columns)))) + +(define foreign-key-def + (tokens-ci "foreign" "key" + name <- (zero-one sql-identifier #f) + columns <- sql-identifiers/paren + (string-ci= "references") + table <- sql-identifier + (zero-one (string-ci= "on") "on") + fk-columns <- sql-identifiers/paren + (return `(foreign-key ,name ,columns ,table ,fk-columns)))) + +;; (provide create-table-def) +(define sql-def (choice create-table-def)) + +(define read-sql (make-reader sql-def)) + +(provide read-sql) diff --git a/ebus-racket/3rdparty/bzlib/parseq/info.ss b/ebus-racket/3rdparty/bzlib/parseq/info.ss new file mode 100644 index 0000000..689c099 --- /dev/null +++ b/ebus-racket/3rdparty/bzlib/parseq/info.ss @@ -0,0 +1,35 @@ +#lang setup/infotab +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; PARSEQ.PLT +;; A Parser Combinator library. +;; +;; Bonzai Lab, LLC. All rights reserved. +;; +;; Licensed under LGPL. +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; info.ss +;; yc 12/31/2009 - first version +(define name "BZLIB/PARSEQ: a monadic parser combinator library") + +(define blurb + '((p "Inspired by Haskell's Parse, bzlib/parsec provides a monadic parser combinator library that can handle both character and binary data parsing. "))) + +(define release-notes + '((p "0.4 (1 3) - added ability to parse exponents to real-number, and updated read-json to handle single quoted string") + (p "0.3 (1 2) - added additional tokenizers") + (p "0.2 (1 1) - fixed a bug with the all-of combinator") + (p "0.1 (1 0) - first release"))) + +(define categories + '(devtools net misc)) + +(define homepage "http://weblambda.blogspot.com") + +(define required-core-version "4.0") + +(define version "0.3") + +(define repositories '("4.x")) + +(define primary-file "main.ss") + diff --git a/ebus-racket/3rdparty/bzlib/parseq/input.ss b/ebus-racket/3rdparty/bzlib/parseq/input.ss new file mode 100644 index 0000000..406b6f2 --- /dev/null +++ b/ebus-racket/3rdparty/bzlib/parseq/input.ss @@ -0,0 +1,83 @@ +#lang scheme/base +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; PARSEQ.PLT +;; A Parser Combinator library. +;; +;; Bonzai Lab, LLC. All rights reserved. +;; +;; Licensed under LGPL. +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; input.ss - holds the abstraction of the input object... +;; yc 12/31/2009 - first version +;; yc 1/8/2009 - fix build-input & Input/c +(require scheme/contract) +;; state +;; the struct that abstracts the input +;; currently this holds an input-port + the position on the port +;; in the future this can be used to hold string, list, vector, etc. +(define-struct input (source pos) #:prefab) + +;; input +;; an utility for converting source into input state. +(define (build-input v (pos 0)) + (define (helper v) + (cond ((input-port? v) v) + ((string? v) (open-input-string v)) + ((bytes? v) (open-input-bytes v)))) + (if (input? v) + (new-input v pos) + (make-input (helper v) pos))) + +;; new-input +;; make a new input based on the old input and a new position... +(define (new-input input incr) + (make-input (input-source input) + (+ incr (input-pos input)))) + +;; peek-bytes* +;; return a funtion that will make a particular amount of reading based on +;; the requested size... +(define (peek-bytes* size) + (lambda (in) + (peek-bytes size (input-pos in) (input-source in)))) + +;; peek-string* +;; return a function that will read a particular size of string... +;; this can fail since it is expected to be using utf-8 as the input size... +(define (peek-string* size) + (lambda (in) + (peek-string size (input-pos in) (input-source in)))) + +;; peek-byte* +;; peek a single byte +(define (peek-byte* in) + (peek-byte (input-source in) (input-pos in))) + +;; peek-char* +;; peek a single char +(define (peek-char* in) + (peek-char (input-source in) (input-pos in))) + +;; read-bytes* +;; read out the bytes based on the size of the input... +(define (read-bytes* in) + (read-bytes (input-pos in) (input-source in))) + +(define Input/c (or/c input? bytes? string? input-port?)) + +(define Parser/c (-> Input/c (values any/c Input/c))) + +(provide input + input? + input-source + input-pos + (rename-out (build-input make-input)) + new-input + peek-bytes* + peek-string* + peek-byte* + peek-char* + read-bytes* + Input/c + Parser/c + )
\ No newline at end of file diff --git a/ebus-racket/3rdparty/bzlib/parseq/main.ss b/ebus-racket/3rdparty/bzlib/parseq/main.ss new file mode 100644 index 0000000..407ef93 --- /dev/null +++ b/ebus-racket/3rdparty/bzlib/parseq/main.ss @@ -0,0 +1,32 @@ +#lang scheme/base +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; PARSEQ.PLT +;; A Parser Combinator library. +;; +;; Bonzai Lab, LLC. All rights reserved. +;; +;; Licensed under LGPL. +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; main.ss - wrapper around the main modules +;; yc 12/31/2009 - first version +;; yc 1/5/2010 - added token.ss +;; yc 1/18/2010 - add reader.ss + +(require "input.ss" + "util.ss" + "primitive.ss" + "combinator.ss" + "basic.ss" + "token.ss" + "reader.ss" + ) +(provide (all-from-out "input.ss" + "util.ss" + "primitive.ss" + "combinator.ss" + "basic.ss" + "token.ss" + "reader.ss" + ) + ) + diff --git a/ebus-racket/3rdparty/bzlib/parseq/primitive.ss b/ebus-racket/3rdparty/bzlib/parseq/primitive.ss new file mode 100644 index 0000000..2fcece5 --- /dev/null +++ b/ebus-racket/3rdparty/bzlib/parseq/primitive.ss @@ -0,0 +1,233 @@ +#lang scheme/base +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; PARSEQ.PLT +;; A Parser Combinator library. +;; +;; Bonzai Lab, LLC. All rights reserved. +;; +;; Licensed under LGPL. +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; primitive.ss - holds the primitive parsers... +;; yc 12/31/2009 - first version +;; yc 1/5/2010 - added literal & literal-ci +;; yc 1/18/2010 - move make-reader to reader.ss + +(require "depend.ss" + "util.ss" + "input.ss" + scheme/contract + ) + +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; primitive parsers + +;; return +(define (return v (size 0)) + (lambda (in) + (values v + (new-input in size)))) + +;; struct failed - represents failed parse... +(define-struct failed (pos) #:prefab) + +;; succeeded? +(define (succeeded? v) (not (failed? v))) + +;; fail - the parser that returns failed with the current port position. +(define (fail in) + (values (make-failed (input-pos in)) + in)) + +;; SOF (start-of-file) +;; returns true only when the input-pos = 0 +(define (SOF in) + ((if (= (input-pos in) 0) + (return 'sof) + fail) in)) + +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; item-based primitive parsers + +;; item +;; the fundamental building block +(define (item peek isa? satisfy? size) + (lambda (in) + (let ((v (peek in))) + ((if (and (isa? v) (satisfy? v)) + (return v (size v)) + fail) in)))) + +;; bytes= +;; parses if the next part of the input matches the exact bytes +(define (bytes= bytes) + (let ((size (bytes-length bytes))) + (item (peek-bytes* size) + bytes? + (lambda (b) + (bytes=? b bytes)) + (the-number size)))) + +;; string= +;; parses if the next part of the input matches the exact string +(define (string= s (comp? string=?)) + (let ((size (string-bytes/utf-8-length s))) + (item (peek-string* size) + string? + (lambda (str) + (comp? str s)) + (the-number size)))) + +(define (string-ci= s) + (string= s string-ci=?)) + +;; byte-when +;; return the next byte when satisfy matches +(define (byte-when satisfy? (isa? byte?) (size (the-number 1))) + (item peek-byte* isa? satisfy? size)) + +;; any-byte +;; return the next byte +(define any-byte (byte-when identity)) + +;; byte= +(define (byte= b) (byte-when (lambda (v) + (= b v)))) + +;; EOF +;; return if the next byte is eof +(define EOF (byte-when identity eof-object? (the-number 0))) + +;; bits= +;; matches a byte @ the bits level... (pass in the individual bits) +(define (bits= bits) + (byte-when (lambda (b) (= b (bits->byte bits))))) + +;; byte-in +(define (byte-in bytes) + (byte-when (lambda (b) (member b bytes)))) + +(define (byte-not-in bytes) + (byte-when (lambda (b) (not (member b bytes))))) + +(define (byte-between lb hb) + (byte-when (lambda (b) (<= lb b hb)))) + +(define (byte-not-between lb hb) + (byte-when (compose not (lambda (b) (<= lb b hb))))) + +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; character-based parsers + +;; char-when +;; the fundamental character-based parser +(define (char-when satisfy?) + (item peek-char* char? satisfy? char-utf-8-length)) + +;; any-char +;; return the next character +(define any-char (char-when identity)) + +;; char= +;; return the next character if it equals c +(define (char= c (comp? char=?) (trans identity)) + (char-when (lambda (v) (trans (comp? c v))))) + +;; char-ci= +(define (char-ci= c) (char= c char-ci=?)) + +;; char-not +;; return the next character if it is not c +(define (char-not= c (comp? char=?)) (char= c comp? not)) + +;; char-ci-not +(define (char-ci-not= c) (char-not= char-ci=?)) + +;; char-between +;; return the next character if it falls in between lc & hc +(define (char-between lc hc (comp? char<=?) (trans identity)) + (char-when (lambda (v) (trans (comp? lc v hc))))) + +;; char-ci-between +(define (char-ci-between lc hc) (char-between lc hc char-ci<=?)) + +(define (char-not-between lc hc (comp? char<=?)) + (char-between lc hc comp? not)) + +;; char-ci-not-between +(define (char-ci-not-between lc hc) (char-not-between lc hc char-ci<=?)) + +;; char-in +;; return the next character if it one of the chars +(define (char-in chars (comp? char=?) (trans identity)) + (char-when (lambda (v) + (trans (memf (lambda (c) + (comp? c v)) + chars))))) + +;; char-ci-in +(define (char-ci-in chars) (char-in chars char-ci=?)) + +;; char-not-in +;; return the next character if it is not one of the characters +(define (char-not-in chars (comp? char=?)) (char-in chars comp? not)) + +;; char-ci-not-in +(define (char-ci-not-in chars) (char-not-in chars char-ci=?)) + +;; literal +;; returns a parser based on the passed in literal +(define (literal p) + (cond ((char? p) (char= p)) + ((byte? p) (byte= p)) + ((string? p) (string= p)) + ((bytes? p) (bytes= p)) + (else p))) + +;; literal-ci +;; a ci version of literal +(define (literal-ci p) + (cond ((char? p) (char-ci= p)) + ((string? p) (string-ci= p)) + (else (literal p)))) + +(define Literal/c (or/c string? bytes? char? byte?)) + +(define Literal-Parser/c (or/c Literal/c Parser/c)) + +(provide return + (struct-out failed) + succeeded? + fail + SOF + item + bytes= + string= + string-ci= + byte-when + any-byte + byte= + EOF + bits= + byte-in + byte-not-in + byte-between + byte-not-between + char-when + any-char + char= + char-ci= + char-not= + char-ci-not= + char-between + char-ci-between + char-not-between + char-ci-not-between + char-in + char-ci-in + char-not-in + char-ci-not-in + literal + literal-ci + Literal/c + Literal-Parser/c + ) diff --git a/ebus-racket/3rdparty/bzlib/parseq/reader.ss b/ebus-racket/3rdparty/bzlib/parseq/reader.ss new file mode 100644 index 0000000..50a5f9d --- /dev/null +++ b/ebus-racket/3rdparty/bzlib/parseq/reader.ss @@ -0,0 +1,41 @@ +#lang scheme/base +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; PARSEQ.PLT +;; A Parser Combinator library. +;; +;; Bonzai Lab, LLC. All rights reserved. +;; +;; Licensed under LGPL. +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; reader.ss - move make-reader & Reader/c here +;; yc 1/18/2010 - first version +;; yc 1/21/2010 - make-reader to take on additional default params +(require "depend.ss" + "input.ss" + "primitive.ss" + "combinator.ss" + (prefix-in c: scheme/contract) + ) +;; use this to create a reader that will read the bytes if the parse succeeds. +(define (make-reader parser #:sof? (sof? #t) #:eof? (eof? #t) #:default (default #f)) + (lambda (in #:sof? (sof? sof?) #:eof? (eof? eof?) #:default (default default)) + (let-values (((v in) + ((seq (if sof? SOF (return #t)) + v <- parser + (if eof? EOF (return #t)) + (return v)) (make-input in)))) + (unless (failed? v) (read-bytes* in)) + (if (failed? v) + default + v)))) + +(define Reader/c (c:->* (Input/c) + (#:sof? boolean? #:eof? boolean? #:default c:any/c) + c:any)) +(provide Reader/c) +(c:provide/contract + (make-reader (c:->* (Parser/c) + (#:sof? boolean? #:eof? boolean? #:default c:any/c) + Reader/c)) + ) + diff --git a/ebus-racket/3rdparty/bzlib/parseq/token.ss b/ebus-racket/3rdparty/bzlib/parseq/token.ss new file mode 100644 index 0000000..cbeb492 --- /dev/null +++ b/ebus-racket/3rdparty/bzlib/parseq/token.ss @@ -0,0 +1,100 @@ +#lang scheme/base +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; PARSEQ.PLT +;; A Parser Combinator library. +;; +;; Bonzai Lab, LLC. All rights reserved. +;; +;; Licensed under LGPL. +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; token.ss - token-based parser combinators. +;; yc 1/5/2010 - first version +;; yc 1/31/2010 - add tokens/by to allow for custom tokenizer, fix token to consume trailing whitespaces as well... +(require "primitive.ss" + "combinator.ss" + "basic.ss" + "input.ss" + mzlib/defmacro + (for-syntax scheme/base + scheme/match + ) + scheme/list + ) + +;; token +;; tokenizing a particular value... +(define (token parser (delim whitespaces)) + (seq delim + t <- parser + delim + (return t))) + +(define (token/pre parser (delim whitespaces)) + (seq delim t <- parser (return t))) + +(define-macro (tokens/by tokenizer . exps) + (define (body exps) + (match exps + ((list exp) (list exp)) + ((list-rest v '<- exp rest) + `(,v <- (,tokenizer ,exp) . ,(body rest))) + ((list-rest exp rest) + `((,tokenizer ,exp) . ,(body rest))))) + `(seq . ,(body exps))) + +;; tokens +;; generating a sequence of tokens... +(define-macro (tokens . exps) + `(tokens/by token . ,exps)) + +;; token-ci +;; the literal tokens for string & character are case-insensitive +(define-macro (tokens-ci . exps) + `(tokens/by (compose token literal-ci) . ,exps)) + +;; alternate +;; alternate between 2 parsers - ideally used for parsing delimited input +;; you can choose whether you want to have the delimiter returned... +(define (alternate parser1 parser2) + (tokens v <- parser1 + v2 <- (zero-many (seq v1 <- parser2 + v3 <- parser1 + (return (list v1 v3)))) + (return (flatten (cons v v2))))) + +;; delimited +;; same as alternate, except the delimiters are parsed out and not returned +(define (delimited parser delim (tokenizer token)) + (tokens/by tokenizer + v <- parser + v2 <- (zero-many (tokens/by tokenizer + v3 <- delim + v4 <- parser + (return v4))) + (return (cons v v2)))) + +;; bracket +;; parsing bracketed structures... +(define (bracket open parser close) + (tokens open + v <- parser + close + (return v))) + +;; bracket/delimited +(define (bracket/delimited open parser delim close) + (tokens open ;; even the parser is optional... + v <- (zero-one (delimited parser delim) '()) + close + (return v))) + +(provide token + token/pre + tokens/by + tokens + tokens-ci + alternate + delimited + bracket + bracket/delimited + ) diff --git a/ebus-racket/3rdparty/bzlib/parseq/util.ss b/ebus-racket/3rdparty/bzlib/parseq/util.ss new file mode 100644 index 0000000..822ce3c --- /dev/null +++ b/ebus-racket/3rdparty/bzlib/parseq/util.ss @@ -0,0 +1,53 @@ +#lang scheme/base +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; PARSEQ.PLT +;; A Parser Combinator library. +;; +;; Bonzai Lab, LLC. All rights reserved. +;; +;; Licensed under LGPL. +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; util.ss - an utility module... the code might be moved out of here... +;; yc 12/31/2009 - first version + +(require mzlib/etc + ) + +;; the-number +;; makes a function that returns a particular number no matter what +;; args are passed in +(define (the-number n) + (lambda args n)) + +;; bits->byte +;; convert a list of bits into its corresponding byte (or integer...) +;; note the byte can be greater than 255 +(define (bits->byte bits) + (define (->i bit) + (case bit + ((0 #f) 0) + ((1 #t) 1))) + (apply + + (map (lambda (bit exponent) + (* (->i bit) (expt 2 exponent))) + bits + (reverse (build-list (length bits) identity))))) + +;; byte->bits +;; the reverse of converting byte to bits... +(define (byte->bits b) + (define (helper q acc) + (cond ((= 0 q) acc) + (else + (let-values (((q r) + (quotient/remainder q 2))) + (helper q (cons r acc)))))) + (helper b '())) + +;; string-bytes/utf-8-length +;; return the bytes length for a string (instead of character length) +(define (string-bytes/utf-8-length s) + (bytes-length (string->bytes/utf-8 s))) + +(provide (all-defined-out)) + diff --git a/ebus-racket/3rdparty/xexpr-path/main.rkt b/ebus-racket/3rdparty/xexpr-path/main.rkt new file mode 100644 index 0000000..97e7f81 --- /dev/null +++ b/ebus-racket/3rdparty/xexpr-path/main.rkt @@ -0,0 +1,99 @@ +#lang racket/base +; +; XML-Expression Path Lookup +; + +(require racket/contract + racket/string + racket/match + racket/dict + racket/list + xml) + +(provide xexpr-path-first + xexpr-path-list + xexpr-path-text + xexpr-path/c) + + +(define xexpr-path/c + (listof (or/c symbol? + (list/c symbol? string?) + (list/c symbol?)))) + + +(define (children element) + (match element + ((list tag (list (list name value) ...) children ...) + children) + + ((list tag children ...) + children) + + (else + null))) + + +(define (attr-value?? name value) + (lambda (v) + (equal? (dict-ref (attributes v) name #f) value))) + + +(define (tag-name?? name) + (lambda (v) + (or (eq? name '*) + (and (pair? v) + (eq? (car v) name))))) + + +(define (attributes element) + (match element + ((list tag (list (list name value) ...) children ...) + (for/list ((n (in-list name)) + (v (in-list value))) + (cons n v))) + + (else + null))) + + +(define (path-item-procedure item) + (match item + ((list attr-name attr-value) + (lambda (tags) + (list (filter (attr-value?? attr-name attr-value) tags)))) + + ((list attr-name) + (lambda (tags) + (list + (filter values + (for/list ((tag (in-list tags))) + (dict-ref (attributes tag) attr-name #f)))))) + + (tag-name + (lambda (tags) + (for/list ((tag (in-list tags))) + (filter (tag-name?? tag-name) (children tag))))))) + + +(define/contract (xexpr-path-list path xexpr) + (-> xexpr-path/c xexpr/c (listof (or/c xexpr/c string?))) + (let ((pipeline (append* (for/list ((item (in-list path))) + (list (path-item-procedure item) append*))))) + ((apply compose (reverse pipeline)) (list xexpr)))) + + +(define/contract (xexpr-path-first path xexpr) + (-> xexpr-path/c xexpr/c (or/c xexpr/c string? #f)) + (let ((results (xexpr-path-list path xexpr))) + (and (not (null? results)) + (first results)))) + + +(define/contract (xexpr-path-text path xexpr) + (-> xexpr-path/c xexpr/c (or/c #f string?)) + (let ((results (xexpr-path-list path xexpr))) + (string-append* (map xexpr->string results)))) + + +; vim:set ts=2 sw=2 et: diff --git a/ebus-racket/3rdparty/zitterbewegung/uuid/.DS_Store b/ebus-racket/3rdparty/zitterbewegung/uuid/.DS_Store Binary files differnew file mode 100644 index 0000000..49ce62a --- /dev/null +++ b/ebus-racket/3rdparty/zitterbewegung/uuid/.DS_Store diff --git a/ebus-racket/3rdparty/zitterbewegung/uuid/uuid-v4.ss b/ebus-racket/3rdparty/zitterbewegung/uuid/uuid-v4.ss new file mode 100644 index 0000000..9aa6aa4 --- /dev/null +++ b/ebus-racket/3rdparty/zitterbewegung/uuid/uuid-v4.ss @@ -0,0 +1,81 @@ +#lang scheme + +(require srfi/27) + +;;From Gambit Scheme Released under the LGPL +;; UUID generation +;; See: http://www.ietf.org/rfc/rfc4122.txt +;; +;; Version 4 UUID, see section 4.4 +(provide make-uuid + urn) +(define random-integer-65536 + (let* ((rs (make-random-source)) + (ri (random-source-make-integers rs))) + (random-source-randomize! rs) + (lambda () + (ri 65536)))) + +(define (make-uuid) + (define hex + '#(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\A #\B #\C #\D #\E #\F)) + (let ((n1 (random-integer-65536)) + (n2 (random-integer-65536)) + (n3 (random-integer-65536)) + (n4 (random-integer-65536)) + (n5 (random-integer-65536)) + (n6 (random-integer-65536)) + (n7 (random-integer-65536)) + (n8 (random-integer-65536))) + (string->symbol + (string + ;; time_lo + (vector-ref hex (extract-bit-field 4 12 n1)) + (vector-ref hex (extract-bit-field 4 8 n1)) + (vector-ref hex (extract-bit-field 4 4 n1)) + (vector-ref hex (extract-bit-field 4 0 n1)) + (vector-ref hex (extract-bit-field 4 12 n2)) + (vector-ref hex (extract-bit-field 4 8 n2)) + (vector-ref hex (extract-bit-field 4 4 n2)) + (vector-ref hex (extract-bit-field 4 0 n2)) + #\- + ;; time_mid + (vector-ref hex (extract-bit-field 4 12 n3)) + (vector-ref hex (extract-bit-field 4 8 n3)) + (vector-ref hex (extract-bit-field 4 4 n3)) + (vector-ref hex (extract-bit-field 4 0 n3)) + #\- + ;; time_hi_and_version + (vector-ref hex #b0100) + (vector-ref hex (extract-bit-field 4 8 n4)) + (vector-ref hex (extract-bit-field 4 4 n4)) + (vector-ref hex (extract-bit-field 4 0 n4)) + #\- + ;; clock_seq_hi_and_reserved + (vector-ref hex (bitwise-ior (extract-bit-field 2 12 n5) #b1000)) + (vector-ref hex (extract-bit-field 4 8 n5)) + ;; clock_seq_low + (vector-ref hex (extract-bit-field 4 4 n5)) + (vector-ref hex (extract-bit-field 4 0 n5)) + #\- + ;; node + (vector-ref hex (extract-bit-field 4 12 n6)) + (vector-ref hex (extract-bit-field 4 8 n6)) + (vector-ref hex (extract-bit-field 4 4 n6)) + (vector-ref hex (extract-bit-field 4 0 n6)) + (vector-ref hex (extract-bit-field 4 12 n7)) + (vector-ref hex (extract-bit-field 4 8 n7)) + (vector-ref hex (extract-bit-field 4 4 n7)) + (vector-ref hex (extract-bit-field 4 0 n7)) + (vector-ref hex (extract-bit-field 4 12 n8)) + (vector-ref hex (extract-bit-field 4 8 n8)) + (vector-ref hex (extract-bit-field 4 4 n8)) + (vector-ref hex (extract-bit-field 4 0 n8)))))) + +(define (extract-bit-field size position n) + (bitwise-and (bitwise-not (arithmetic-shift -1 size)) + (arithmetic-shift n (- position)))) + +(define (urn) + (string-append "urn:uuid:" + (symbol->string (make-uuid)))) diff --git a/ebus-racket/README.md b/ebus-racket/README.md new file mode 100644 index 0000000..d639139 --- /dev/null +++ b/ebus-racket/README.md @@ -0,0 +1,16 @@ +# Ebus Racket + +## Inserting into influxdb + +``` +./reader.rkt --insert --influx-url http://... </dev/tty... + +#see also: +./reader --help +``` + +## Tests + +``` +raco test tests/ +```
\ No newline at end of file diff --git a/ebus-racket/ebus/layer2.rkt b/ebus-racket/ebus/layer2.rkt new file mode 100644 index 0000000..f9bc31a --- /dev/null +++ b/ebus-racket/ebus/layer2.rkt @@ -0,0 +1,98 @@ +#lang racket/base +(require (only-in racket/bool false?) + "../3rdparty/bzlib/parseq/main.ss") + +(define-logger ebus2) + +(define ebus-const-syn #xaa) ;; SYN +(define ebus-const-escape #xa9) ;; Escape-Sequence Start +(define ebus-const-ackok #x00) ;; ACK +(define ebus-const-broadcastaddr #xfe) ;; Broadcast Address + +(struct ebus-body-broadcast (crc) #:transparent) + +(struct ebus-body-mastermaster (crc) #:transparent) + +(struct ebus-body-masterslave + (crc payloadSlaveLength payloadSlave crcSlave) + #:transparent) + +(struct ebus-paket + (source destination primaryCommand secondaryCommand payloadLength payload body) + #:transparent) + +;; single, maybe escaped, payload data byte +(define ebus-payload + (choice (seq escape-seq <- ebus-const-escape + escape-code <- (byte-in (list 0 1)) + (return (cond + ((= escape-code 0) ebus-const-escape) + ((= escape-code 1) bytes ebus-const-syn)))) + any-byte + )) + +(define parse-ebus-broadcast + (token (seq crc <- any-byte + syn <- ebus-const-syn + (return (ebus-body-broadcast crc))))) + +(define parse-ebus-mastermaster + (token (seq crc <- any-byte + ack <- ebus-const-ackok ;; ACK des Empfängers + syn <- ebus-const-syn ;; SYN des Senders + (return (ebus-body-mastermaster crc))))) + +(define parse-ebus-masterslave + (token (seq crc <- any-byte + ack <- ebus-const-ackok ;; ACK des Empfängers + payloadSlaveLength <- any-byte + payloadSlave <- (repeat ebus-payload payloadSlaveLength payloadSlaveLength) + crcSlave <- any-byte + ackSlave <- ebus-const-ackok ;; ACK des Senders + synSlave <- ebus-const-syn ;; SYN des Senders + (return (ebus-body-masterslave crc payloadSlaveLength payloadSlave crcSlave))))) + +(define parse-ebus-paket + (token (seq source <- any-byte + destination <- any-byte + primaryCommand <- any-byte + secondaryCommand <- any-byte + payloadLength <- any-byte + payload <- (repeat ebus-payload payloadLength payloadLength) + body <- (cond ((= destination ebus-const-broadcastaddr) parse-ebus-broadcast) + (else (choice parse-ebus-mastermaster + parse-ebus-masterslave))) + (return (ebus-paket source + destination + primaryCommand + secondaryCommand + payloadLength + payload + body))))) + +(define ebus-sync (tokens syncs <- (seq (repeat (string->bytes/latin-1 "\xaa"))) + (return (length syncs)))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define (read-ebus input-port) + (define syn ((make-reader ebus-sync #:sof? #f #:eof? #f) input-port)) + (define paket ((make-reader parse-ebus-paket #:sof? #f #:eof? #f) input-port)) + (cond ((not (false? syn)) (log-ebus2-debug "dropped ~a x SYN (~a)" syn ebus-const-syn))) + (cond ((not (false? paket)) paket) + ((eof-object? (peek-byte input-port)) eof) + (else + ;; skip one byte + (let ([byte (read-byte input-port)]) + (log-ebus2-debug "drop ~s 0x~x" byte byte)) + (read-ebus input-port)))) + +(provide + ;; Read Layer Ebus-Paket `ebus-paket` + read-ebus + ;; Expose datastructures + (struct-out ebus-paket) + (struct-out ebus-body-broadcast) + (struct-out ebus-body-mastermaster) + (struct-out ebus-body-masterslave)) diff --git a/ebus-racket/ebus/layer7.rkt b/ebus-racket/ebus/layer7.rkt new file mode 100644 index 0000000..1ecf271 --- /dev/null +++ b/ebus-racket/ebus/layer7.rkt @@ -0,0 +1,208 @@ +#lang racket/base +(require + (only-in racket/bool false?) + (only-in racket/function curry) + (only-in xml collapse-whitespace + xexpr-drop-empty-attributes + xml->xexpr + document-element + read-xml) + (only-in "../3rdparty/xexpr-path/main.rkt" + xexpr-path-first + xexpr-path-list) + (prefix-in layer2- "layer2.rkt")) + +(define-logger ebus7) + +(define (ersatzwert) 'ersatzwert) +(define (ersatzwert? v) (eq? (ersatzwert) v)) + +(define (read-ebus-xml path) + (let* ([in (open-input-file path)] + [xexpr (parameterize ([collapse-whitespace #t] + [xexpr-drop-empty-attributes #t]) + (xml->xexpr (document-element (read-xml in))))]) + (close-input-port in) + xexpr)) + +(define definition (make-parameter null)) + +(define (paket ebus-paket) + (define primaryCommand (number->string (layer2-ebus-paket-primaryCommand ebus-paket))) + (define secondaryCommand (number->string (layer2-ebus-paket-secondaryCommand ebus-paket))) + (log-ebus7-debug "Lookup paket primaryCommand=~a secondaryCommand=~a" primaryCommand secondaryCommand) + (xexpr-path-first (list 'packets 'packet (list 'primary primaryCommand) + (list 'secondary secondaryCommand)) (definition))) + +(define (paket-name xexpr) + (xexpr-path-first '((name)) xexpr)) + +(define (paket-fields paket-definition) + (filter + (lambda (i) (and (pair? i) (member (car i) '(bit bcd data1b data1c byte data2b data2c word byteEnum)))) + (xexpr-path-list '(fields *) paket-definition))) + +;; returns the full device-definition +(define (device address) + (xexpr-path-first (list 'devices 'device (list 'address (number->string address))) (definition))) + +;; returns device-name in a list or empty-list +(define (device-name address) + (xexpr-path-first (list 'devices 'device (list 'address (number->string address)) '(name)) (definition))) + +(define (paket-parse ebus-paket) + (define paket-definition (paket ebus-paket)) + (define source-device-name (device-name (layer2-ebus-paket-source ebus-paket))) + (cond ((and (not (false? paket-definition)) (not (false? source-device-name))) + (define paket-id (string-append source-device-name "." (paket-name paket-definition))) + (define decoders (map (lambda (field) (create-decoder paket-id field)) (paket-fields paket-definition))) + (define payload (layer2-ebus-paket-payload ebus-paket)) + (for/list ([decoder decoders]) + (decoder payload))) + (else (void (log-ebus7-info "Unknown Paket from source ~s(~s): ~s" + (layer2-ebus-paket-source ebus-paket) + source-device-name + ebus-paket))))) + + +(define (create-decoder paket-id field) + (define type (car field)) + (define name (string-append paket-id "." (xexpr-path-first '((name)) field))) + (define offset (string->number (xexpr-path-first '((offset)) field))) + (define decoder (hash-ref decoder-table type #f)) + (cond ((false? decoder) (void (log-ebus7-warning "No decoder for type ~s" type))) + (else (curry (car decoder) name field offset)))) + +(define decoder-table + (make-hash (list + (list 'bit (lambda (name field offset payload) + (list name 'bit (field-decoder-bit (list-ref payload offset))))) + (list 'byte (lambda (name field offset payload) + (list name 'byte (field-decoder-byte (list-ref payload offset))))) + (list 'bcd (lambda (name field offset payload) + (list name 'bcd (field-decoder-bcd (list-ref payload offset))))) + (list 'data1b (lambda (name field offset payload) + (list name 'data1b (field-decoder-data1b (list-ref payload offset))))) + (list 'data1c (lambda (name field offset payload) + (list name 'data1c (field-decoder-data1c (list-ref payload offset))))) + (list 'data2b (lambda (name field offset payload) + (list name 'data2b (field-decoder-data2b + (list-ref payload offset) + (list-ref payload (+ offset 1)))))) + (list 'data2c (lambda (name field offset payload) + (list name 'data2c + (field-decoder-data2c (list-ref payload offset) (list-ref payload (+ offset 1)))))) + (list 'word (lambda (name field offset payload) + (list name 'word (field-decoder-word (list-ref payload offset) (list-ref payload (+ offset 1)))))) + (list 'byteEnum (lambda (name field offset payload) + (list name 'byteEnum (field-decoder-byteEnum (list-ref payload offset) field)))) + ))) + +;; type bit +(define (field-decoder-bit value) + (cond ((= value 1) 1) + (else 0))) + +;; type byte +(define (field-decoder-byte value) + (cond ((= value #xff) (ersatzwert)) + (else value))) + +;; type data1b +(define (field-decoder-data1b value) + (if (= value #x80) + (ersatzwert) + (cond ((= 1 (arithmetic-shift value -7)) + (* -1 (+ 1 (bitwise-xor #xff value)))) + (else value)))) + +;; type data1c +(define (field-decoder-data1c value) + (if (= value #xff) + (ersatzwert) + (/ value 2.0))) + +;; type data2b +(define (field-decoder-data2b lowByte highByte) + (if (and (= highByte 128) (= lowByte 0)) + (ersatzwert) + (if (= (bitwise-and highByte 128) 128) + (* -1 + (+ (+ 256 (bitwise-not highByte)) + (/ (+ 256 (bitwise-not (+ lowByte 1))) 256.0))) + (+ highByte (/ lowByte 256.0))))) + +;; type data2c +;; Beispiel für die Berechnung: +;; if ((x & 8000h) == 8000h) // y negativ +;; y = - [dez(High_Byte(!x)) 16 + dez(High_Nibble (Low_Byte (!x))) +;; + (dez(Low_Nibble (Low_Byte (!x))) +1 ) / 16] +;; else // y positiv +;; y = dez(High_Byte(x)) 16 + dez(High_ Nibble (Low Byte (x))) +;; + dez(Low_ Nibble (Low Byte (x))) / 16 +(define (field-decoder-data2c lowByte highByte) + (define (lowNibble v) + (bitwise-and v #x0f)) + (define (highNibble v) + (arithmetic-shift v -4)) + (define (u-not v) + (+ 256 (bitwise-not v))) + + (if (and (= highByte 128) (= lowByte 0)) + (ersatzwert) + (if (= (bitwise-and highByte 128) 128) + (* -1 + (+ (arithmetic-shift (u-not highByte) 4) + (highNibble (u-not lowByte)) + (/ (+ (lowNibble (u-not lowByte)) 1) + 16.0))) + (+ (arithmetic-shift highByte 4) + (highNibble lowByte) + (/ + (lowNibble lowByte) + 16))))) + +;; type byteEnum +(define (field-decoder-byteEnum value field-definition) + (define (pred l) + (= value (list-ref l 0))) + (define all-options (for/list ([option (xexpr-path-list '(option) field-definition)]) + (list (string->number (xexpr-path-first '((value)) option)) ;; '(value name) + (xexpr-path-first '((name)) option)))) + (define options (filter pred all-options)) + (cond ((= (length options) 1) + (list-ref (car options) 1)) + (else (format "<undefined:~a>" value)))) + +;; type word +(define (field-decoder-word lowByte highByte) + (define value + (+ lowByte (arithmetic-shift highByte 8))) + (if (= value #xffff) + (ersatzwert) + value)) + +;; type bcd +(define (field-decoder-bcd value) + (cond ((= value #xff) (ersatzwert)) + (else (+ (bitwise-and value #x0f) + (* (arithmetic-shift value -4) 10))))) + +;; read one ebus-paket or eof from input-port +;; or return #<eof> +(define (read-ebus input-port) + (define paket (layer2-read-ebus input-port)) + (cond ((layer2-ebus-paket? paket) + (paket-parse paket)) + (else paket))) + +(provide ersatzwert + ersatzwert? + read-ebus-xml + paket + paket-parse + paket-fields + device + definition + ;; read ebus from port an return fields from next paket + read-ebus) diff --git a/ebus-racket/reader.rkt b/ebus-racket/reader.rkt new file mode 100755 index 0000000..438b807 --- /dev/null +++ b/ebus-racket/reader.rkt @@ -0,0 +1,82 @@ +#!/usr/bin/env racket +#lang racket/base +(require racket/cmdline + racket/stream + racket/string + data/queue + net/url + (prefix-in layer7- "ebus/layer7.rkt")) + +(define-logger inserter) + +(define insert? (make-parameter #f)) +(define influx-url? (make-parameter null)) +(define influx-queue (make-queue)) +(define influx-queue-size? (make-parameter 0)) +(define ebus-xml-path? (make-parameter "../ebus-xml/ebus.xml")) + +;; Send fields to database server +(define (insert-influxdb sensor-name datatype value) + (if (layer7-ersatzwert? value) + (log-inserter-debug "Skipping Ersatzwert for ~a/~a" sensor-name datatype) + ;; Some basic formatting rules. This must satisfy the influxdb "Write Protocol" + ;; https://docs.influxdata.com/influxdb/v0.13/write_protocols/line/ + (let* ([raw-value (cond ((member datatype '(data1c data2b data2c)) (real->decimal-string (exact->inexact value))) + ((member datatype '(bit byte data1b word bcd)) (format "~s" value)) + ((member datatype '(byteEnum)) (format "\"~s\"" value)))] + [point (format "~a,type=~a value=~a" sensor-name (symbol->string datatype) raw-value)]) + (enqueue! influx-queue point) + (log-inserter-debug (format "influxdb: ~a~n" point)) + (when (> (queue-length influx-queue) (influx-queue-size?)) + (let ([points (queue->list influx-queue)]) ;; empty the queue + (log-inserter-info "Make bulk insert to ~a" (influx-url?)) + (for-each (lambda (e) (dequeue! influx-queue)) (queue->list influx-queue)) + (define input-port (post-impure-port (string->url (influx-url?)) + (string->bytes/utf-8 (string-join points (format "~n"))))) + (log-inserter-info "Server Response: ~a~n" (read-line input-port)) + (log-inserter-info "Data: ~a~n" (string-join points "|")) + (close-input-port input-port)))))) + +(define (handle-packet packet) + (for ([field packet]) + (when (insert?) + (with-handlers ([exn:fail? (lambda (exn) + (log-inserter-error "Failed to insert ~a: ~a" field exn))] + [exn:fail:read? (lambda (exn) + (log-inserter-error "TCP Read exception ~a" exn))] + [exn:fail:network? (lambda (exn) + (log-inserter-error "TCP Exception ~a" exn))]) + (apply insert-influxdb field))) + (when (not (insert?)) + (apply (lambda (sensor-name datatype value) + (printf "No Insert: (~a) ~a=~a~n" datatype sensor-name value)) + field)))) + +(define (make-stream port) + (stream-cons + (with-handlers ([exn:fail? (lambda (exn) + (log-inserter-error "Failed to parse packet: ~a" exn) + (void))]) + (layer7-read-ebus port)) + (make-stream port))) + +(define (main) + ;; Parse commandline + (command-line + #:once-each + ["--insert" "Do Insert into Database" + (insert? #t)] + ["--influx-url" url "Influx server http write url" + (influx-url? url)] + ["--ebus-xml" ebus-xml-path "Influx server http write url" + (ebus-xml-path? ebus-xml-path)]) + + (parameterize ([layer7-definition (layer7-read-ebus-xml (ebus-xml-path?))]) + ;; process ebus packets from stdin + (for ([packet (make-stream (current-input-port))]) + (when (not (or (void? packet) (eof-object? packet))) + (handle-packet packet)) + (when (eof-object? packet) + (exit 1))))) + +(exit (main)) diff --git a/ebus-racket/tests/layer2-test.rkt b/ebus-racket/tests/layer2-test.rkt new file mode 100644 index 0000000..6be2ba8 --- /dev/null +++ b/ebus-racket/tests/layer2-test.rkt @@ -0,0 +1,71 @@ +#lang racket/base +(require rackunit + rackunit/text-ui + (prefix-in layer2- "../ebus/layer2.rkt")) + +(define layer2-test + (test-suite + "Tests for Ebus Parser" + (test-case + "Test sample Master-Master Paket" + (let + ([paket (layer2-read-ebus + (open-input-bytes + (bytes + 170 ; SYN + 170 + 003 ; Source + 241 ; Destination + 008 ; primaryCommand + 000 ; secondaryCommand + 008 ; payloadLength + 128 ; p1 + 040 ; p2 + 230 ; p3 + 002 ; p4 + 000 ; p5 + 002 ; p6 + 000 ; p7 + 010 ; p8 + 128 ; CRC + 000 ; ACK + 170 ; SYN + 170)))]) + (check-eq? (layer2-ebus-paket-source paket) 003) + (check-eq? (layer2-ebus-paket-destination paket) 241) + (check-eq? (layer2-ebus-paket-primaryCommand paket) 008) + (check-eq? (layer2-ebus-paket-secondaryCommand paket) 000) + (check-eq? (layer2-ebus-paket-payloadLength paket) 008) + (check-eq? (layer2-ebus-paket-payloadLength paket) + (length (layer2-ebus-paket-payload paket))) + )) + (test-case + "test invalid paket" + (let + ([paket (layer2-read-ebus + (open-input-bytes + (bytes + 170 ;SYN + 170 ;SYN + 016 ;SRC + 003 ;DEST + 008 ;PRIM => sollwertuebertragungRegler + 000 ;SEC => sollwertuebertragungRegler + 008 ;PAY + 051 ;P1 + 042 ;P2 + 000 ;P3 + 009 ;P4 + 128 ;P5 + 019 ;P6 + 000 ;P7 | ACK + 045 ;P8 | ??? + 170 ;SYN + 170 ;SYN + )))]) + (check-eq? paket eof) + )) + )) + + +(exit (run-tests layer2-test)) diff --git a/ebus-racket/tests/layer7-test.rkt b/ebus-racket/tests/layer7-test.rkt new file mode 100644 index 0000000..5fa8c4a --- /dev/null +++ b/ebus-racket/tests/layer7-test.rkt @@ -0,0 +1,62 @@ +#lang racket/base +(require rackunit + rackunit/text-ui + racket/list + (prefix-in layer2- "../ebus/layer2.rkt") + (prefix-in layer7- "../ebus/layer7.rkt")) + +(define layer7-test + (test-suite + "Tests for Ebus Layer 7 Parser" + (test-case + "Test sample Master-Master Paket" + (parameterize ([layer7-definition (layer7-read-ebus-xml "../../ebus-xml/ebus.xml")]) + (let* + ([l2paket (layer2-read-ebus (open-input-bytes (bytes + 170 ; SYN + 170 + 003 ; Source + 241 ; Destination + 008 ; primaryCommand + 000 ; secondaryCommand + 008 ; payloadLength + 128 ; p1 + 040 ; p2 + 230 ; p3 + 002 ; p4 + 200 ; p5 + 002 ; p6 + 000 ; p7 + 010 ; p8 + 128 ; CRC + 000 ; ACK + 170 ; SYN + 170)))] + [fields (layer7-paket-parse l2paket)]) + (for ([field fields]) + (display field) + (display "\n")) + (check-true (= 5 (length fields)) "Anzahl der gelesenen Felder") + (let ([p (first fields)]) + (check-equal? (first p) "feuerungsautomat1.sollwertuebertragungRegler.TK_soll") + (check-equal? (second p) 'data2b) + (check-equal? (third p) 40.5)) + (let ([p (second fields)]) + (check-equal? (first p) "feuerungsautomat1.sollwertuebertragungRegler.TA_ist") + (check-equal? (second p) 'data2b) + (check-equal? (third p) 2.8984375)) + (let ([p (third fields)]) + (check-equal? (first p) "feuerungsautomat1.sollwertuebertragungRegler.L_zwang") + (check-equal? (second p) 'data1b) + (check-equal? (third p) -56)) + (let ([p (fourth fields)]) + (check-equal? (first p) "feuerungsautomat1.sollwertuebertragungRegler.Status") + (check-equal? (second p) 'bit) + (check-equal? (third p) 0)) + (let ([p (fifth fields)]) + (check-equal? (first p) "feuerungsautomat1.sollwertuebertragungRegler.TB_soll") + (check-equal? (second p) 'data2b) + (check-equal? (third p) 10)) + ))))) + +(exit (run-tests layer7-test)) diff --git a/ebus-xml/Makefile b/ebus-xml/Makefile new file mode 100644 index 0000000..1a8f4fc --- /dev/null +++ b/ebus-xml/Makefile @@ -0,0 +1,16 @@ +TARGET_DIST=dist/$(shell date --rfc-3339=date) + +all: doc + +doc: + test -d build || mkdir build + xsltproc ebus.docbook.xslt ebus.xml > build/ebus.docbook.xml + dblatex -T db2latex build/ebus.docbook.xml + +dist: doc + test -d $(TARGET_DIST) || mkdir -p $(TARGET_DIST) + cp build/ebus.docbook.pdf $(TARGET_DIST) + cp ebus.xml $(TARGET_DIST) + +validate: + xmllint --noout --schema ebus-0.1.xsd ebus.xml diff --git a/ebus-xml/dist/2011-06-25/ebus.docbook.pdf b/ebus-xml/dist/2011-06-25/ebus.docbook.pdf Binary files differnew file mode 100644 index 0000000..819f85e --- /dev/null +++ b/ebus-xml/dist/2011-06-25/ebus.docbook.pdf diff --git a/ebus-xml/dist/2016-08-14/ebus.docbook.pdf b/ebus-xml/dist/2016-08-14/ebus.docbook.pdf Binary files differnew file mode 100644 index 0000000..dfba6fc --- /dev/null +++ b/ebus-xml/dist/2016-08-14/ebus.docbook.pdf diff --git a/ebus-xml/dist/2016-08-14/ebus.xml b/ebus-xml/dist/2016-08-14/ebus.xml new file mode 100644 index 0000000..39ebca8 --- /dev/null +++ b/ebus-xml/dist/2016-08-14/ebus.xml @@ -0,0 +1,258 @@ +<?xml version="1.0" standalone="yes"?> +<!-- Ebus Paketspezifikation. https://xapek.org/ --> +<ebus xmlns="http://xapek.org/ebus/0.1" xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance" + xsi:schemaLocation="http://xapek.org/ebus/0.1 ebus-0.1.xsd"> + <devices> + <device address="0" type="master" name="pcModem"> + <description lang="de">PC oder Modem</description> + <description lang="en">PC or Modem</description> + </device> + <device address="3" type="master" name="feuerungsautomat1"> + <description lang="de">Feuerungsautomat 1</description> + </device> + <device address="10" type="master" name="rcClockModel"> + <description lang="de">RC-Clock Model</description> + </device> + <device address="7" type="master" name="unknown"> + <description lang="de">Unbekannt</description> + </device> + <device address="16" type="master" name="heizkreisregler2"> + <description lang="de">Heizkreisregler 2</description> + </device> + <device address="17" type="master" name="busInterface1"> + <description lang="de">Bus Interface 1</description> + </device> + <device address="19" type="master" name="feuerungsautomat2"> + <description lang="de">Feuerungsautomat 2</description> + </device> + <device address="48" type="master" name="heizkreisregler1"> + <description lang="de">Heizkreisregler 1</description> + </device> + <device address="49" type="master" name="busInterface2"> + <description lang="de">Bus Interface 2</description> + </device> + <device address="51" type="master" name="feuerungsautomat3"> + <description lang="de">Feuerungsautomat 3</description> + </device> + <device address="112" type="master" name="heizkreisregler2"> + <description lang="de">Heizkreisregler 2</description> + </device> + <device address="113" type="master" name="heizkreisregler9"> + <description lang="de">Heizkreisregler 9</description> + </device> + <device address="115" type="master" name="feuerungsautomat4"> + <description lang="de">Feuerungsautomat 4</description> + </device> + <device address="241" type="master" name="heizkreisregler10"> + <description lang="de">Heizkreisregler 10</description> + </device> + <device address="80" type="slave" name="mischer1"> + <description lang="de">Mischer 1</description> + </device> + <device address="81" type="slave" name="mischer2"> + <description lang="de">Mischer 2</description> + </device> + <device address="144" type="slave" name="fernsteller1"> + <description lang="de">Raumgeräte/Fernsteller 1</description> + </device> + <device address="145" type="slave" name="fernsteller2"> + <description lang="de">Raumgeräte/Fernsteller 2</description> + </device> + <device address="240" type="master" name="heizkreisregler3"> + <description lang="de">Heizkreisregler 3</description> + </device> + <device address="240" type="master" name="feuerungsautomat5"> + <description lang="de">Feuerungsautomat 5</description> + </device> + <device address="254" type="broadcast" name="broadcast"> + <description lang="de">Broadcast-Adresse</description> + </device> + <device address="255" type="master" name="pc"> + <description lang="de">PC</description> + </device> + </devices> + <packets> + <packet primary="5" secondary="3" name="betriebsdatenRegler1"> + <description lang="de">Betriebsdaten des Feuerungsautomaten an den Regler Block1</description> + <fields> + <byte offset="3" name="stellgradKesselleistung"> + <description lang="de">Stellgrad Kesselleistung</description> + </byte> + <data1c offset="4" name="kesselTemperatur"> + <description lang="de">Kessel Temperatur</description> + </data1c> + <byte offset="5" name="ruecklaufTemperatur"> + <description lang="de">Rücklauf Temperatur</description> + </byte> + <byte offset="6" name="boilerTemperatur"> + <description lang="de">Boiler Temperatur</description> + </byte> + <data1b offset="7" name="aussenTemperatur"> + <description lang="de">Aussentemperatur</description> + </data1b> + </fields> + </packet> + <packet primary="5" secondary="7" + name="betriebsdatenFeuerungsautomat"> + <description lang="de">"Betriebsdaten des Reglers an den Feuerungsautomaten</description> + <fields> + <byteEnum offset="0" name="betriebszustand"> + <option value="0" name="brennerAbschalten"> + <description lang="de">Brenner Abschalten</description> + </option> + <option value="1" name="keineAktion"> + <description lang="de">Keine Aktion</description> + </option> + <option value="85" name="brauchwasserbereitung"> + <description lang="de">Brauchwasserbereitung</description> + </option> + <option value="170" name="heizbetrieb"> + <description lang="de">Heizbetrieb</description> + </option> + <option value="204" name="emissionskontrolle"> + <description lang="de">Emissionskontrolle</description> + </option> + <option value="221" name="tuevFunktion"> + <description lang="de">TÜV Funktion</description> + </option> + <option value="238" name="reglerStopp"> + <description lang="de">Regler Stopp</description> + </option> + <option value="102" name="brauchwasserReglerstopp"> + <description lang="de">Brauchwasserbereitung bei Reglerstoppfunktion</description> + </option> + <option value="187" name="brauchwasserHeizbetrieb"> + <description lang="de">Brauchwasserbereitung bei Heizbetrieb</description> + </option> + <option value="68" name="reglerstoppStufig"> + <description lang="de">Reglerstoppfunktion bei stufigem Betrieb</description> + </option> + </byteEnum> + <byteEnum offset="1" name="aktion"> + <option value="0" name="keineAktion"> + <description lang="de">Keine Aktion</description> + </option> + <option value="1" name="ausschaltenKesselpumpe"> + <description lang="de">Ausschalten Kesselpumpe</description> + </option> + <option value="2" name="einschaltenKesselpumpe"> + <description lang="de">Einschalten Kesselpumpe</description> + </option> + <option value="3" name="ausschaltenVariableVerbraucher"> + <description lang="de">Ausschalten variable Verbraucher</description> + </option> + <option value="4" name="einschaltenVariableVerbraucher"> + <description lang="de">Einschalten variable Verbraucher</description> + </option> + </byteEnum> + <data2c offset="2" name="kesselSollwertTemperatur"> + <description lang="de">Kessel Temperatur Sollwert</description> + </data2c> + <data2b offset="4" name="kesselSollwertDruck"> + <description lang="de">Kesseldruck Sollwert</description> + </data2b> + <data1c offset="6" name="stellgrad"> + <description lang="de">Stellgrad</description> + </data1c> + <data1c offset="7" name="brauchwasserSollwert"> + <description lang="de">Brauchwasser Sollwert</description> + </data1c> + </fields> + </packet> + + <packet primary="7" secondary="0" name="datumZeit"> + <description lang="de">Datum/Zeit Meldung eines eBus Master</description> + <fields> + <data2b offset="0" name="aussenTemperatur" /> + <bcd offset="2" name="sekunden" /> + <bcd offset="3" name="minuten" /><!-- FEHLER ab hier beim offset??? --> + <bcd offset="4" name="stunden" /> + <bcd offset="5" name="tag" /> + <bcd offset="6" name="monat" /> + <bcd offset="7" name="wochentag" /> + <bcd offset="8" name="jahr" /> + </fields> + </packet> + + <packet primary="8" secondary="0" name="sollwertuebertragungRegler"> + <description lang="de">Sollwertübertragung des Reglers an andere Regler</description> + <fields> + <data2b offset="0" name="TK_soll"> + <description lang="de">Kessel Sollwert in °C [1/256]</description> + </data2b> + <data2b offset="2" name="TA_ist"> + <description lang="de">Aussentemperatur in °C [1/256]</description> + </data2b> + <data1b offset="4" name="L_zwang"> + <description lang="de">Leistungszwang in Prozent</description> + </data1b> + <bit offset="5" name="Status"> + <description lang="de">Status</description> + </bit> + <data2b offset="6" name="TB_soll"> + <description lang="de">Brauchwassersollwert</description> + </data2b> + </fields> + </packet> + + <packet primary="3" secondary="8" name="brenstoffmengeLesen"> + <description lang="de">Gesamtbrennstoffmenge Lesen</description> + <fields /> + </packet> + + <!-- #x50, Kromschröder Spezial --> + <packet primary="80" secondary="20" name="vorlauftemperatur"> + <description lang="de">Reversed from http://www.mikrocontroller.net/topic/91164#1070401</description> + <fields> + <data2b offset="0" name="vorlauftemperaturIst"> + <description lang="de">Aktuelle Vorlauftemperatur + Mischerkreis</description> + </data2b> + <data2b offset="2" name="vorlauftemperaturSoll"> + <description lang="de">Soll Vorlaufteperatur + Mischerkreis</description> + </data2b> + </fields> + </packet> + + <packet primary="80" secondary="23" name="solarDaten"> + <description lang="de">Solar Daten</description> + <fields> + <bit offset="0" name="solarPumpe"> + <description lang="de">Betriebszustand Solarpumpe</description> + </bit> + <data2c offset="2" name="tempKollektor"> + <description lang="de">>Wassertemperatur am Kollektor</description> + </data2c> + <data2c offset="4" name="tempWarmwasserSolar"> + <description lang="de">Warmwassertemperatur am + Kollektor</description> + </data2c> + </fields> + </packet> + + <packet primary="80" secondary="24" name="solarDatenSumme"> + <description lang="de">Reversed siehe ebus-wiki</description> + <fields> + <data2b offset="0" name="aktuelleLeistung"> + <description lang="de">Aktuelle Solarleistung</description> + </data2b> + <word offset="2" name="tagesertragLow"> + <description lang="de">Tagesertrag low</description> + </word> + <word offset="4" name="tagesertragHigh"> + <description lang="de">Tagesertrag high * 1000</description> + </word> + <word offset="6" name="ertragssumme"> + <description lang="de">Ertragssumme</description> + </word> + <word offset="8" name="ertragssummeT"> + <description lang="de">Ertragssumme T * 1000</description> + </word> + <word offset="10" name="ertragssummeM"> + <description lang="de">Etragssumme M * 1000 * 1000</description> + </word> + </fields> + </packet> + </packets> +</ebus> diff --git a/ebus-xml/ebus-0.1.xsd b/ebus-xml/ebus-0.1.xsd new file mode 100644 index 0000000..4e96176 --- /dev/null +++ b/ebus-xml/ebus-0.1.xsd @@ -0,0 +1,158 @@ +<?xml version="1.0" encoding="UTF-8"?> +<schema xmlns="http://www.w3.org/2001/XMLSchema" targetNamespace="http://xapek.org/ebus/0.1" + xmlns:tns="http://xapek.org/ebus/0.1" elementFormDefault="qualified"> + <element name="ebus"> + <complexType> + <sequence> + <element name="devices"> + <complexType> + <sequence minOccurs="0"> + <element name="device" type="tns:DEVICE" + maxOccurs="unbounded" /> + </sequence> + </complexType> + </element> + <element name="packets"> + <complexType> + <sequence minOccurs="0"> + <element name="packet" type="tns:PACKET" + maxOccurs="unbounded" /> + </sequence> + </complexType> + </element> + </sequence> + </complexType> + </element> + + <complexType name="DEVICE"> + <annotation> + <documentation xml:lang="en"> + Example: >device + address="#x10" type="master" + name="heizkreisregler1"<Heizkreisregler 2>/device< + </documentation> + </annotation> + <sequence> + <element name="description" type="tns:DESCRIPTION" + minOccurs="0" maxOccurs="unbounded" /> + </sequence> + <attribute name="address" type="short" use="required" /> + <attribute name="type" type="string" use="required" /> + <attribute name="name" type="string" use="required" /> + </complexType> + + <complexType name="PACKET"> + <annotation> + <documentation xml:lang="en">TODO</documentation> + </annotation> + <sequence> + <element name="description" type="tns:DESCRIPTION" + minOccurs="0" maxOccurs="unbounded" /> + <element name="fields" type="tns:FIELDS" minOccurs="1" + maxOccurs="1" /> + </sequence> + <attribute name="primary" type="short" use="required" /> + <attribute name="secondary" type="short" use="required" /> + <attribute name="name" type="string" use="required" /> + </complexType> + + <complexType name="DESCRIPTION"> + <simpleContent> + <extension base="string"> + <attribute name="lang" type="string" use="required" /> + </extension> + </simpleContent> + </complexType> + + <complexType name="FIELDS"> + <choice minOccurs="0" maxOccurs="unbounded"> + <element name="byte" type="tns:FIELD_BYTE" /> + <element name="data1b" type="tns:FIELD_DATA1B"></element> + <element name="data1c" type="tns:FIELD_DATA1C"></element> + <element name="bcd" type="tns:FIELD_BCD"></element> + <element name="data2b" type="tns:FIELD_DATA2B"></element> + <element name="data2c" type="tns:FIELD_DATA2C"></element> + <element name="word" type="tns:FIELD_WORD"></element> + <element name="bit" type="tns:FIELD_BIT"></element> + <element name="byteEnum" type="tns:FIELD_BYTE_ENUM" /> + </choice> + </complexType> + + <complexType name="FIELD_BASE_TYPE"> + <sequence> + <element name="description" type="tns:DESCRIPTION" + minOccurs="0" maxOccurs="unbounded" /> + </sequence> + <attribute name="offset" type="int" use="required" /> + <attribute name="name" type="string" use="required" /> + </complexType> + + + + <complexType name="FIELD_BYTE" final="#all"> + <complexContent> + <extension base="tns:FIELD_BASE_TYPE"></extension> + </complexContent> + </complexType> + + <complexType name="FIELD_DATA1B"> + <complexContent> + <extension base="tns:FIELD_BASE_TYPE"></extension> + </complexContent> + </complexType> + + <complexType name="FIELD_DATA1C"> + <complexContent> + <extension base="tns:FIELD_BASE_TYPE"></extension> + </complexContent> + </complexType> + + <complexType name="FIELD_BCD"> + <complexContent> + <extension base="tns:FIELD_BASE_TYPE"></extension> + </complexContent> + </complexType> + + <complexType name="FIELD_DATA2B"> + <complexContent> + <extension base="tns:FIELD_BASE_TYPE"></extension> + </complexContent> + </complexType> + + <complexType name="FIELD_DATA2C"> + <complexContent> + <extension base="tns:FIELD_BASE_TYPE"></extension> + </complexContent> + </complexType> + + <complexType name="FIELD_WORD"> + <complexContent> + <extension base="tns:FIELD_BASE_TYPE"></extension> + </complexContent> + </complexType> + + <complexType name="FIELD_BIT"> + <complexContent> + <extension base="tns:FIELD_BASE_TYPE"></extension> + </complexContent> + </complexType> + + <complexType name="FIELD_BYTE_ENUM" final="#all"> + <complexContent> + <extension base="tns:FIELD_BASE_TYPE"> + <sequence> + <element name="option" minOccurs="1" maxOccurs="unbounded"> + <complexType> + <sequence> + <element name="description" type="tns:DESCRIPTION" + minOccurs="0" maxOccurs="unbounded" /> + </sequence> + <attribute name="value" type="short" use="required"></attribute> + <attribute name="name" type="string" use="required"></attribute> + </complexType> + </element> + </sequence> + </extension> + </complexContent> + </complexType> +</schema> diff --git a/ebus-xml/ebus.docbook.xslt b/ebus-xml/ebus.docbook.xslt new file mode 100644 index 0000000..c6c80c5 --- /dev/null +++ b/ebus-xml/ebus.docbook.xslt @@ -0,0 +1,244 @@ +<?xml version="1.0" encoding="utf8"?> +<xsl:stylesheet version="1.0" + xmlns:xsl="http://www.w3.org/1999/XSL/Transform" + xmlns:ebus="http://xapek.org/ebus/0.1" xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance" + xmlns:db="http://docbook.org/ns/docbook" + xsi:schemaLocation=" + http://xapek.org/ebus/0.1 ebus-0.1.xsd + http://docbook.org/ns/docbook http://docbook.org/xml/5.0/xsd/docbook.xsd" +> + <xsl:output method="xml" indent="yes"/> + + <xsl:template match="/"> + <db:book version="5.0" xml:lang="de"> + <db:info> + <db:title>Ebus Protokollbeschreibung</db:title> + <db:author> + <db:personname>Yves Fischer</db:personname> + <db:email>yvesf+git@xapek.org</db:email> + </db:author> + </db:info> + <db:chapter> + <db:title>Adressen</db:title> + <db:sect1> + <db:title>Master Adressen</db:title> + <xsl:call-template name="do_devices"> + <xsl:with-param name="type" select="'master'"/> + </xsl:call-template> + </db:sect1> + <db:sect1> + <db:title>Slave Adressen</db:title> + <xsl:call-template name="do_devices"> + <xsl:with-param name="type" select="'slave'"/> + </xsl:call-template> + </db:sect1> + <db:sect1> + <db:title>Broadcast Adressen</db:title> + <xsl:call-template name="do_devices"> + <xsl:with-param name="type" select="'broadcast'"/> + </xsl:call-template> + </db:sect1> + </db:chapter> + <db:chapter> + <db:title>Pakete</db:title> + + <db:informaltable pgwide="1"> + <db:tgroup cols="3"> + <db:colspec colnum="1" colname="c1" colwidth="5cm"/> + <db:colspec colnum="2" colname="c2" colwidth="1.8cm"/> + <db:colspec colnum="3" colname="c3"/> + <db:thead> + <db:row> + <db:entry>Packet</db:entry> + <db:entry>Prim./Sec. Address</db:entry> + <db:entry>Description</db:entry> + </db:row> + </db:thead> + <db:tbody> + <xsl:for-each select="ebus:ebus/ebus:packets/ebus:packet"> + <db:row> + <db:entry> + <xsl:element name="db:link"> + <xsl:attribute name="linkend"> + <xsl:value-of select="concat('link.packet.', @name)"/> + </xsl:attribute> + <xsl:value-of select="@name"/> + </xsl:element> + </db:entry> + <db:entry> + <db:computeroutput> + <xsl:value-of select="format-number(@primary, '00')"/> / + <xsl:value-of select="format-number(@secondary, '00')"/> + </db:computeroutput> + </db:entry> + <db:entry> + <xsl:for-each select="ebus:description"> + <db:para> + <db:emphasis><xsl:value-of select="@lang"/>: + </db:emphasis> + <xsl:value-of select="text()"/> + </db:para> + </xsl:for-each> + </db:entry> + </db:row> + </xsl:for-each> + </db:tbody> + </db:tgroup> + </db:informaltable> + <db:sect1> + <db:title>Fields</db:title> + <xsl:for-each select="ebus:ebus/ebus:packets/ebus:packet"> + <xsl:call-template name="do_packet"/> + </xsl:for-each> + </db:sect1> + </db:chapter> + </db:book> + </xsl:template> + + <xsl:template name="do_packet"> + <db:sect2> + <db:title> + <xsl:value-of select="@name"/> + </db:title> + <xsl:element name="db:anchor"> + <xsl:attribute name="id"> + <xsl:value-of select="concat('link.packet.', @name)"/> + </xsl:attribute> + </xsl:element> + + <db:informaltable pgwide="1"> + <db:tgroup cols="4"> + <db:colspec colname="c1"/> + <db:colspec colname="c2" colwidth=".8cm"/> + <db:colspec colname="c3" colwidth="1.5cm"/> + <db:colspec colname="c4"/> + <db:thead> + <db:row> + <db:entry>Name</db:entry> + <db:entry>Offset</db:entry> + <db:entry>Type</db:entry> + <db:entry>Description</db:entry> + </db:row> + </db:thead> + <db:tbody> + <xsl:for-each select="ebus:fields/*"> + <db:row> + <db:entry> + <xsl:value-of select="@name"/> + </db:entry> + <db:entry> + <xsl:value-of select="@offset"/> + </db:entry> + <db:entry> + <xsl:value-of select="name()"/> + </db:entry> + <db:entry> + <xsl:for-each select="ebus:description"> + <db:para> + <db:emphasis> + <xsl:value-of select="concat(@lang, ': ')"/> + </db:emphasis> + <xsl:value-of select="text()"/> + </db:para> + </xsl:for-each> + </db:entry> + </db:row> + + <xsl:if test="name() = 'byteEnum'"> + <db:row> + <db:entry namest="c1" nameend="c4"> + <xsl:call-template name="enuminfo"/> + </db:entry> + </db:row> + </xsl:if> + </xsl:for-each> + </db:tbody> + </db:tgroup> + </db:informaltable> + + <xsl:for-each select="ebus:fields/*"> + + </xsl:for-each> + </db:sect2> + </xsl:template> + + <xsl:template name="enuminfo"> + <db:informaltable pgwide="1"> + <db:tgroup cols="3"> + <db:colspec colname="c1"/> + <db:colspec colname="c2"/> + <db:colspec colname="c3"/> + <db:thead> + <db:row> + <db:entry>Code</db:entry> + <db:entry>Name</db:entry> + <db:entry>Description</db:entry> + </db:row> + </db:thead> + <db:tbody> + <xsl:for-each select="ebus:option"> + <db:row> + <db:entry> + <xsl:value-of select="@value"/> + </db:entry> + <db:entry> + <xsl:value-of select="@name"/> + </db:entry> + <db:entry> + <xsl:for-each select="ebus:description"> + <db:para> + <db:emphasis> + <xsl:value-of select="concat(@lang, ': ')"/> + </db:emphasis> + <xsl:value-of select="text()"/> + </db:para> + </xsl:for-each> + </db:entry> + </db:row> + </xsl:for-each> + </db:tbody> + </db:tgroup> + </db:informaltable> + <db:para/> + </xsl:template> + + <xsl:template name="do_devices"> + <xsl:param name="type"/> + <db:informaltable pgwide="1" frame="none"> + <db:tgroup cols="3"> + <db:colspec colname="c1"/> + <db:colspec colname="c2"/> + <db:colspec colname="c3"/> + <db:thead> + <db:row> + <db:entry>Gerät</db:entry> + <db:entry>Address</db:entry> + <db:entry>Description</db:entry> + </db:row> + </db:thead> + <db:tbody> + <xsl:for-each select="ebus:ebus/ebus:devices/ebus:device[@type=$type]"> + <db:row> + <db:entry> + <xsl:value-of select="@name"/> + </db:entry> + <db:entry> + <xsl:value-of select="@address"/> + </db:entry> + <db:entry> + <xsl:for-each select="ebus:description"> + <db:para> + <db:emphasis> + <xsl:value-of select="concat(@lang, ': ')"/> + </db:emphasis> + <xsl:value-of select="text()"/> + </db:para> + </xsl:for-each> + </db:entry> + </db:row> + </xsl:for-each> + </db:tbody> + </db:tgroup> + </db:informaltable> + </xsl:template> +</xsl:stylesheet>
\ No newline at end of file diff --git a/ebus-xml/ebus.xml b/ebus-xml/ebus.xml new file mode 100644 index 0000000..a4552ba --- /dev/null +++ b/ebus-xml/ebus.xml @@ -0,0 +1,256 @@ +<?xml version="1.0" standalone="yes"?> +<!-- Ebus Paketspezifikation. https://xapek.org/ --> +<ebus xmlns="http://xapek.org/ebus/0.1" xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance" + xsi:schemaLocation="http://xapek.org/ebus/0.1 ebus-0.1.xsd"> + <devices> + <device address="0" type="master" name="pcModem"> + <description lang="de">PC oder Modem</description> + <description lang="en">PC or Modem</description> + </device> + <device address="3" type="master" name="feuerungsautomat1"> + <description lang="de">Feuerungsautomat 1</description> + </device> + <device address="10" type="master" name="rcClockModel"> + <description lang="de">RC-Clock Model</description> + </device> + <device address="7" type="master" name="unknown"> + <description lang="de">Unbekannt</description> + </device> + <device address="16" type="master" name="heizkreisregler2"> + <description lang="de">Heizkreisregler 2</description> + </device> + <device address="17" type="master" name="busInterface1"> + <description lang="de">Bus Interface 1</description> + </device> + <device address="19" type="master" name="feuerungsautomat2"> + <description lang="de">Feuerungsautomat 2</description> + </device> + <device address="48" type="master" name="heizkreisregler1"> + <description lang="de">Heizkreisregler 1</description> + </device> + <device address="49" type="master" name="busInterface2"> + <description lang="de">Bus Interface 2</description> + </device> + <device address="51" type="master" name="feuerungsautomat3"> + <description lang="de">Feuerungsautomat 3</description> + </device> + <device address="112" type="master" name="heizkreisregler2"> + <description lang="de">Heizkreisregler 2</description> + </device> + <device address="113" type="master" name="heizkreisregler9"> + <description lang="de">Heizkreisregler 9</description> + </device> + <device address="115" type="master" name="feuerungsautomat4"> + <description lang="de">Feuerungsautomat 4</description> + </device> + <device address="241" type="master" name="heizkreisregler10"> + <description lang="de">Heizkreisregler 10</description> + </device> + <device address="80" type="slave" name="mischer1"> + <description lang="de">Mischer 1</description> + </device> + <device address="81" type="slave" name="mischer2"> + <description lang="de">Mischer 2</description> + </device> + <device address="144" type="slave" name="fernsteller1"> + <description lang="de">Raumgeräte/Fernsteller 1</description> + </device> + <device address="145" type="slave" name="fernsteller2"> + <description lang="de">Raumgeräte/Fernsteller 2</description> + </device> + <device address="240" type="master" name="heizkreisregler3"> + <description lang="de">Heizkreisregler 3</description> + </device> + <device address="240" type="master" name="feuerungsautomat5"> + <description lang="de">Feuerungsautomat 5</description> + </device> + <device address="254" type="broadcast" name="broadcast"> + <description lang="de">Broadcast-Adresse</description> + </device> + <device address="255" type="master" name="pc"> + <description lang="de">PC</description> + </device> + </devices> + <packets> + <packet primary="5" secondary="3" name="betriebsdatenRegler1"> + <description lang="de">Betriebsdaten des Feuerungsautomaten an den Regler Block1</description> + <fields> + <byte offset="3" name="stellgradKesselleistung"> + <description lang="de">Stellgrad Kesselleistung</description> + </byte> + <data1c offset="4" name="kesselTemperatur"> + <description lang="de">Kessel Temperatur</description> + </data1c> + <byte offset="5" name="ruecklaufTemperatur"> + <description lang="de">Rücklauf Temperatur</description> + </byte> + <byte offset="6" name="boilerTemperatur"> + <description lang="de">Boiler Temperatur</description> + </byte> + <data1b offset="7" name="aussenTemperatur"> + <description lang="de">Aussentemperatur</description> + </data1b> + </fields> + </packet> + <packet primary="5" secondary="7" name="betriebsdatenFeuerungsautomat"> + <description lang="de">"Betriebsdaten des Reglers an den Feuerungsautomaten</description> + <fields> + <byteEnum offset="0" name="betriebszustand"> + <option value="0" name="brennerAbschalten"> + <description lang="de">Brenner Abschalten</description> + </option> + <option value="1" name="keineAktion"> + <description lang="de">Keine Aktion</description> + </option> + <option value="85" name="brauchwasserbereitung"> + <description lang="de">Brauchwasserbereitung</description> + </option> + <option value="170" name="heizbetrieb"> + <description lang="de">Heizbetrieb</description> + </option> + <option value="204" name="emissionskontrolle"> + <description lang="de">Emissionskontrolle</description> + </option> + <option value="221" name="tuevFunktion"> + <description lang="de">TÜV Funktion</description> + </option> + <option value="238" name="reglerStopp"> + <description lang="de">Regler Stopp</description> + </option> + <option value="102" name="brauchwasserReglerstopp"> + <description lang="de">Brauchwasserbereitung bei Reglerstoppfunktion</description> + </option> + <option value="187" name="brauchwasserHeizbetrieb"> + <description lang="de">Brauchwasserbereitung bei Heizbetrieb</description> + </option> + <option value="68" name="reglerstoppStufig"> + <description lang="de">Reglerstoppfunktion bei stufigem Betrieb</description> + </option> + </byteEnum> + <byteEnum offset="1" name="aktion"> + <option value="0" name="keineAktion"> + <description lang="de">Keine Aktion</description> + </option> + <option value="1" name="ausschaltenKesselpumpe"> + <description lang="de">Ausschalten Kesselpumpe</description> + </option> + <option value="2" name="einschaltenKesselpumpe"> + <description lang="de">Einschalten Kesselpumpe</description> + </option> + <option value="3" name="ausschaltenVariableVerbraucher"> + <description lang="de">Ausschalten variable Verbraucher</description> + </option> + <option value="4" name="einschaltenVariableVerbraucher"> + <description lang="de">Einschalten variable Verbraucher</description> + </option> + </byteEnum> + <data2c offset="2" name="kesselSollwertTemperatur"> + <description lang="de">Kessel Temperatur Sollwert</description> + </data2c> + <data2b offset="4" name="kesselSollwertDruck"> + <description lang="de">Kesseldruck Sollwert</description> + </data2b> + <data1c offset="6" name="stellgrad"> + <description lang="de">Stellgrad</description> + </data1c> + <data1c offset="7" name="brauchwasserSollwert"> + <description lang="de">Brauchwasser Sollwert</description> + </data1c> + </fields> + </packet> + + <packet primary="7" secondary="0" name="datumZeit"> + <description lang="de">Datum/Zeit Meldung eines eBus Master</description> + <fields> + <data2b offset="0" name="aussenTemperatur" /> + <bcd offset="2" name="sekunden" /> + <bcd offset="3" name="minuten" /><!-- FEHLER ab hier beim offset??? --> + <bcd offset="4" name="stunden" /> + <bcd offset="5" name="tag" /> + <bcd offset="6" name="monat" /> + <bcd offset="7" name="wochentag" /> + <bcd offset="8" name="jahr" /> + </fields> + </packet> + + <packet primary="8" secondary="0" name="sollwertuebertragungRegler"> + <description lang="de">Sollwertübertragung des Reglers an andere Regler</description> + <fields> + <data2b offset="0" name="TK_soll"> + <description lang="de">Kessel Sollwert in °C [1/256]</description> + </data2b> + <data2b offset="2" name="TA_ist"> + <description lang="de">Aussentemperatur in °C [1/256]</description> + </data2b> + <data1b offset="4" name="L_zwang"> + <description lang="de">Leistungszwang in Prozent</description> + </data1b> + <bit offset="5" name="Status"> + <description lang="de">Status</description> + </bit> + <data2b offset="6" name="TB_soll"> + <description lang="de">Brauchwassersollwert</description> + </data2b> + </fields> + </packet> + + <packet primary="3" secondary="8" name="brenstoffmengeLesen"> + <description lang="de">Gesamtbrennstoffmenge Lesen</description> + <fields /> + </packet> + + <!-- #x50, Kromschröder Spezial --> + <packet primary="80" secondary="20" name="vorlauftemperatur"> + <description lang="de">see http://www.mikrocontroller.net/topic/91164</description> + <fields> + <data2b offset="0" name="vorlauftemperaturIst"> + <description lang="de">Aktuelle Vorlauftemperatur + Mischerkreis</description> + </data2b> + <data2b offset="2" name="vorlauftemperaturSoll"> + <description lang="de">Soll Vorlaufteperatur + Mischerkreis</description> + </data2b> + </fields> + </packet> + + <packet primary="80" secondary="23" name="solarDaten"> + <description lang="de">Solar Daten</description> + <fields> + <bit offset="0" name="solarPumpe"> + <description lang="de">Betriebszustand Solarpumpe</description> + </bit> + <data2c offset="2" name="tempKollektor"> + <description lang="de">Wassertemperatur am Kollektor</description> + </data2c> + <data2c offset="4" name="tempWarmwasserSolar"> + <description lang="de">Warmwassertemperatur am Kollektor</description> + </data2c> + </fields> + </packet> + + <packet primary="80" secondary="24" name="solarDatenSumme"> + <description lang="de">Reversed siehe ebus-wiki</description> + <fields> + <data2b offset="0" name="aktuelleLeistung"> + <description lang="de">Aktuelle Solarleistung</description> + </data2b> + <word offset="2" name="tagesertragLow"> + <description lang="de">Tagesertrag low</description> + </word> + <word offset="4" name="tagesertragHigh"> + <description lang="de">Tagesertrag high * 1000</description> + </word> + <word offset="6" name="ertragssumme"> + <description lang="de">Ertragssumme</description> + </word> + <word offset="8" name="ertragssummeT"> + <description lang="de">Ertragssumme T * 1000</description> + </word> + <word offset="10" name="ertragssummeM"> + <description lang="de">Etragssumme M * 1000 * 1000</description> + </word> + </fields> + </packet> + </packets> +</ebus> |