cond-values: add with example

4 files changed, 622 insertions, 0 deletions

diff --git a/COPYING b/COPYING
new file mode 100644
index 0000000..d645695
--- /dev/null
+++ b/COPYING
@@ -0,0 +1,202 @@
+
+                                 Apache License
+                           Version 2.0, January 2004
+                        http://www.apache.org/licenses/
+
+   TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION
+
+   1. Definitions.
+
+      "License" shall mean the terms and conditions for use, reproduction,
+      and distribution as defined by Sections 1 through 9 of this document.
+
+      "Licensor" shall mean the copyright owner or entity authorized by
+      the copyright owner that is granting the License.
+
+      "Legal Entity" shall mean the union of the acting entity and all
+      other entities that control, are controlled by, or are under common
+      control with that entity. For the purposes of this definition,
+      "control" means (i) the power, direct or indirect, to cause the
+      direction or management of such entity, whether by contract or
+      otherwise, or (ii) ownership of fifty percent (50%) or more of the
+      outstanding shares, or (iii) beneficial ownership of such entity.
+
+      "You" (or "Your") shall mean an individual or Legal Entity
+      exercising permissions granted by this License.
+
+      "Source" form shall mean the preferred form for making modifications,
+      including but not limited to software source code, documentation
+      source, and configuration files.
+
+      "Object" form shall mean any form resulting from mechanical
+      transformation or translation of a Source form, including but
+      not limited to compiled object code, generated documentation,
+      and conversions to other media types.
+
+      "Work" shall mean the work of authorship, whether in Source or
+      Object form, made available under the License, as indicated by a
+      copyright notice that is included in or attached to the work
+      (an example is provided in the Appendix below).
+
+      "Derivative Works" shall mean any work, whether in Source or Object
+      form, that is based on (or derived from) the Work and for which the
+      editorial revisions, annotations, elaborations, or other modifications
+      represent, as a whole, an original work of authorship. For the purposes
+      of this License, Derivative Works shall not include works that remain
+      separable from, or merely link (or bind by name) to the interfaces of,
+      the Work and Derivative Works thereof.
+
+      "Contribution" shall mean any work of authorship, including
+      the original version of the Work and any modifications or additions
+      to that Work or Derivative Works thereof, that is intentionally
+      submitted to Licensor for inclusion in the Work by the copyright owner
+      or by an individual or Legal Entity authorized to submit on behalf of
+      the copyright owner. For the purposes of this definition, "submitted"
+      means any form of electronic, verbal, or written communication sent
+      to the Licensor or its representatives, including but not limited to
+      communication on electronic mailing lists, source code control systems,
+      and issue tracking systems that are managed by, or on behalf of, the
+      Licensor for the purpose of discussing and improving the Work, but
+      excluding communication that is conspicuously marked or otherwise
+      designated in writing by the copyright owner as "Not a Contribution."
+
+      "Contributor" shall mean Licensor and any individual or Legal Entity
+      on behalf of whom a Contribution has been received by Licensor and
+      subsequently incorporated within the Work.
+
+   2. Grant of Copyright License. Subject to the terms and conditions of
+      this License, each Contributor hereby grants to You a perpetual,
+      worldwide, non-exclusive, no-charge, royalty-free, irrevocable
+      copyright license to reproduce, prepare Derivative Works of,
+      publicly display, publicly perform, sublicense, and distribute the
+      Work and such Derivative Works in Source or Object form.
+
+   3. Grant of Patent License. Subject to the terms and conditions of
+      this License, each Contributor hereby grants to You a perpetual,
+      worldwide, non-exclusive, no-charge, royalty-free, irrevocable
+      (except as stated in this section) patent license to make, have made,
+      use, offer to sell, sell, import, and otherwise transfer the Work,
+      where such license applies only to those patent claims licensable
+      by such Contributor that are necessarily infringed by their
+      Contribution(s) alone or by combination of their Contribution(s)
+      with the Work to which such Contribution(s) was submitted. If You
+      institute patent litigation against any entity (including a
+      cross-claim or counterclaim in a lawsuit) alleging that the Work
+      or a Contribution incorporated within the Work constitutes direct
+      or contributory patent infringement, then any patent licenses
+      granted to You under this License for that Work shall terminate
+      as of the date such litigation is filed.
+
+   4. Redistribution. You may reproduce and distribute copies of the
+      Work or Derivative Works thereof in any medium, with or without
+      modifications, and in Source or Object form, provided that You
+      meet the following conditions:
+
+      (a) You must give any other recipients of the Work or
+          Derivative Works a copy of this License; and
+
+      (b) You must cause any modified files to carry prominent notices
+          stating that You changed the files; and
+
+      (c) You must retain, in the Source form of any Derivative Works
+          that You distribute, all copyright, patent, trademark, and
+          attribution notices from the Source form of the Work,
+          excluding those notices that do not pertain to any part of
+          the Derivative Works; and
+
+      (d) If the Work includes a "NOTICE" text file as part of its
+          distribution, then any Derivative Works that You distribute must
+          include a readable copy of the attribution notices contained
+          within such NOTICE file, excluding those notices that do not
+          pertain to any part of the Derivative Works, in at least one
+          of the following places: within a NOTICE text file distributed
+          as part of the Derivative Works; within the Source form or
+          documentation, if provided along with the Derivative Works; or,
+          within a display generated by the Derivative Works, if and
+          wherever such third-party notices normally appear. The contents
+          of the NOTICE file are for informational purposes only and
+          do not modify the License. You may add Your own attribution
+          notices within Derivative Works that You distribute, alongside
+          or as an addendum to the NOTICE text from the Work, provided
+          that such additional attribution notices cannot be construed
+          as modifying the License.
+
+      You may add Your own copyright statement to Your modifications and
+      may provide additional or different license terms and conditions
+      for use, reproduction, or distribution of Your modifications, or
+      for any such Derivative Works as a whole, provided Your use,
+      reproduction, and distribution of the Work otherwise complies with
+      the conditions stated in this License.
+
+   5. Submission of Contributions. Unless You explicitly state otherwise,
+      any Contribution intentionally submitted for inclusion in the Work
+      by You to the Licensor shall be under the terms and conditions of
+      this License, without any additional terms or conditions.
+      Notwithstanding the above, nothing herein shall supersede or modify
+      the terms of any separate license agreement you may have executed
+      with Licensor regarding such Contributions.
+
+   6. Trademarks. This License does not grant permission to use the trade
+      names, trademarks, service marks, or product names of the Licensor,
+      except as required for reasonable and customary use in describing the
+      origin of the Work and reproducing the content of the NOTICE file.
+
+   7. Disclaimer of Warranty. Unless required by applicable law or
+      agreed to in writing, Licensor provides the Work (and each
+      Contributor provides its Contributions) on an "AS IS" BASIS,
+      WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or
+      implied, including, without limitation, any warranties or conditions
+      of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A
+      PARTICULAR PURPOSE. You are solely responsible for determining the
+      appropriateness of using or redistributing the Work and assume any
+      risks associated with Your exercise of permissions under this License.
+
+   8. Limitation of Liability. In no event and under no legal theory,
+      whether in tort (including negligence), contract, or otherwise,
+      unless required by applicable law (such as deliberate and grossly
+      negligent acts) or agreed to in writing, shall any Contributor be
+      liable to You for damages, including any direct, indirect, special,
+      incidental, or consequential damages of any character arising as a
+      result of this License or out of the use or inability to use the
+      Work (including but not limited to damages for loss of goodwill,
+      work stoppage, computer failure or malfunction, or any and all
+      other commercial damages or losses), even if such Contributor
+      has been advised of the possibility of such damages.
+
+   9. Accepting Warranty or Additional Liability. While redistributing
+      the Work or Derivative Works thereof, You may choose to offer,
+      and charge a fee for, acceptance of support, warranty, indemnity,
+      or other liability obligations and/or rights consistent with this
+      License. However, in accepting such obligations, You may act only
+      on Your own behalf and on Your sole responsibility, not on behalf
+      of any other Contributor, and only if You agree to indemnify,
+      defend, and hold each Contributor harmless for any liability
+      incurred by, or claims asserted against, such Contributor by reason
+      of your accepting any such warranty or additional liability.
+
+   END OF TERMS AND CONDITIONS
+
+   APPENDIX: How to apply the Apache License to your work.
+
+      To apply the Apache License to your work, attach the following
+      boilerplate notice, with the fields enclosed by brackets "[]"
+      replaced with your own identifying information. (Don't include
+      the brackets!)  The text should be enclosed in the appropriate
+      comment syntax for the file format. We also recommend that a
+      file or class name and description of purpose be included on the
+      same "printed page" as the copyright notice for easier
+      identification within third-party archives.
+
+   Copyright [yyyy] [name of copyright owner]
+
+   Licensed under the Apache License, Version 2.0 (the "License");
+   you may not use this file except in compliance with the License.
+   You may obtain a copy of the License at
+
+       http://www.apache.org/licenses/LICENSE-2.0
+
+   Unless required by applicable law or agreed to in writing, software
+   distributed under the License is distributed on an "AS IS" BASIS,
+   WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+   See the License for the specific language governing permissions and
+   limitations under the License.
diff --git a/cond-values.scm b/cond-values.scm
new file mode 100644
index 0000000..099536c
--- /dev/null
+++ b/cond-values.scm
@@ -0,0 +1,187 @@
+;;; Copyright 2024 Peter McGoron
+;;; Licensed under the Apache License, Version 2.0 (the "License");
+;;; you may not use this file except in compliance with the License.
+;;; You may obtain a copy of the License at
+;;; 
+;;;     http://www.apache.org/licenses/LICENSE-2.0
+;;; 
+;;; Unless required by applicable law or agreed to in writing, software
+;;; distributed under the License is distributed on an "AS IS" BASIS,
+;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or
+;;; implied. See the License for the specific language governing
+;;; permissions and limitations under the License.
+
+(import srfi-1)
+
+;;; AFTER executes a body after multiple tests.
+;;; 
+;;; The form of the syntax is
+;;; (AFTER (BINDING ...) BODY ...)
+;;; 
+;;; where BODY ... is a Scheme body. Each BINDING is evaluated in order,
+;;; where BINDING is
+;;; 
+;;; (VALUE => FORMAL): FORMAL is a LAMBDA formal and VALUE is a something
+;;; that returns multiple values. If VALUE evaluates to no values, the
+;;; test fails and the entire AFTER form returns no values.
+;;; 
+;;; (WHEN TEST): Evaluates TEST. If TEST is #F then the entire AFTER form
+;;; returns no values.
+;;; 
+;;; If all BINDINGs pass, then BODY is executed and its return value is
+;;; the return of AFTER.
+(define-syntax after
+  (syntax-rules (when let =>)
+    ((after ((let value => formal) conditionals ...) body ...)
+     (call-with-values (lambda () value)
+       (lambda returned
+         (if (null? returned)
+             (values)
+             (apply (lambda formal (after (conditionals ...) body ...))
+                    returned)))))
+    ((after ((let formal value ...) conditionals ...) body ...)
+     (after ((let (begin value ...) => formal) conditionals ...)
+       body ...))
+    ((after ((when boolean) conditionals ...) body ...)
+     (if boolean
+         (after (conditionals ...) body ...)
+         (values)))
+    ((after () body ...)
+     (begin body ...))))
+
+(define-syntax apply-after
+  (syntax-rules ()
+    ((apply-after value receiver)
+     (after ((let value => formal))
+       (apply receiver formal)))))
+
+;;; (COND-VALUES CLAUSE ...) is like COND, but it tests for empty VALUES
+;;; instead of #F.
+;;; 
+;;; Each CLAUSE is:
+;;; 
+;;; (BODY ...): Executes BODY. If BODY returns no values, then try the
+;;; rest of the clauses. If BODY returns values, those values are the
+;;; return values of COND-VALUES.
+;;; (ELSE BODY ...): Must occur at the end. Executes BODY and returns
+;;; whatever BODY returns.
+;;; 
+;;; If there is no ELSE clause and all CLAUSEs fail, COND-VALUES returns
+;;; no values.
+(define-syntax cond-values
+  (syntax-rules (else)
+    ((cond-values (else body ...))
+     (begin body ...))
+    ((cond-values value rest ...)
+     (call-with-values (lambda () value)
+       (lambda returned
+         (if (null? returned)
+             (cond-values rest ...)
+             (apply values returned)))))
+    ((cond-values) (values))))
+
+;;; (DEFINE-RECORD-TYPE/DESTRUCTOR TYPENAME
+;;;   (CSTR FIELDS ...)
+;;;   PREDICATE?
+;;;   DESTRUCTOR
+;;;   (FIELD GETTER SETTER ...)
+;;;   ...)
+;;; 
+;;; creates an SRFI-9/R7RS record type. The syntax is the same, except
+;;; that after the PREDICATE field and before the getter/setter fields
+;;; is an identifier, DESTRUCTOR.
+;;; 
+;;; This macro defines a procedure (DESTRUCTOR RECORD) that returns each
+;;; field of RECORD as values, or no values if RECORD is not a TYPENAME
+;;; record.
+(define-syntax define-record-type/destructor
+  (syntax-rules ()
+    ((define-record-type/destructor typename
+       (cstr fields ...)
+       predicate?
+       destructor
+       (field getter setter ...)
+       ...)
+     (begin
+       (define-record-type typename
+         (cstr fields ...)
+         predicate?
+         (field getter setter ...)
+         ...)
+       (define (destructor record)
+         (after ((when (predicate? record)))
+           (values (getter record) ...)))))))
+
+;;; ;;;;;;;;;;;;;
+;;; Helper functions
+;;; ;;;;;;;;;;;;;
+
+;;; Returns the CAR and CDR of X as values when X is a pair, and no values
+;;; otherwise.
+(define (pair-d x)
+  (after ((when (pair? x)))
+    (values (car x) (cdr x))))
+
+(define (assq-d val alist)
+  (let ((pair (assq val alist)))
+    (after ((when (pair? pair)))
+      (cdr pair))))
+
+;;; Returns the list as values when WHOLE-LIST has length NUM, and no
+;;; values otherwise.
+(define (length* whole-list num)
+  (when (<= num 0)
+    (error "invalid number" 'length* whole-list num))
+
+  (let length* ((lst whole-list)
+                (num num))
+    (cond-values
+      (after ((when (null? lst))
+        (when (= num 0)))
+        (apply values whole-list))
+      (after ((when (pair? lst))
+             (when (> num 0)))
+        (length* (cdr lst) (- num 1))))))
+
+;;; Returns the list as values when WHOLE-LIST has at least length NUM,
+;;; and no values otherwise.
+(define (length-at-least whole-list num)
+  (when (<= num 0)
+    (error "invalid number" 'length-at-least whole-list num))
+
+  (let length-at-least ((lst whole-list)
+                        (num num))
+    (cond-values
+      (after ((when (= num 0))
+              (when (or (null? lst)
+                        (pair? lst))))
+        (apply values whole-list))
+      (after ((when (> num 0))
+              (when (pair? lst)))
+        (length-at-least (cdr lst) (- num 1))))))
+
+;;; Helper function.
+(define (null-cdr? lst) (null? (cdr lst)))
+
+;;; MAP-VALUES returns (VALUES L1 L2 ...), where L1 is the first
+;;; value returned from (F (CAR LST)), (F (CADR LST)), ... and so on.
+(define (map-values f . lists)
+  (define (null-cdr? lst) (null? (cdr lst)))
+  (let-values ((new-values (apply f (map car lists))))
+    (if (any null-cdr? lists)
+        (apply values (map list new-values))
+        (let-values ((returned (apply map-values f (map cdr lists))))
+          (apply values (map cons new-values returned))))))
+
+;;; (ANY-VALUES F (A1 A2 ...) (B1 B2 ...) ...) runs
+;;; (F A1 B1 ...) and checks if there any returned values. If there are
+;;; none, runs (F A2 B2 ...), and so on.
+;;; 
+;;; If any of the lists end, then ANY-VALUES returns no values.
+(define (any-values f . lists)
+  (after ((when (not (null? lists)))
+          (when (all pair? lists)))
+    (let-values ((returned (apply f (map car lists))))
+      (if (null? returned)
+          (apply any-values f (map cdr lists))
+          (apply values returned)))))
diff --git a/units.scm b/units.scm
new file mode 100644
index 0000000..08694a9
--- /dev/null
+++ b/units.scm
@@ -0,0 +1,167 @@
+;;; Copyright 2024 Peter McGoron
+;;; Licensed under the Apache License, Version 2.0 (the "License");
+;;; you may not use this file except in compliance with the License.
+;;; You may obtain a copy of the License at
+;;; 
+;;;     http://www.apache.org/licenses/LICENSE-2.0
+;;; 
+;;; Unless required by applicable law or agreed to in writing, software
+;;; distributed under the License is distributed on an "AS IS" BASIS,
+;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or
+;;; implied. See the License for the specific language governing
+;;; permissions and limitations under the License.
+;;; 
+;;; Example of COND-VALUES using units.
+
+(load "cond-values.scm")
+
+(define *si-prefixes*
+  '((quetta . #e1e30)
+    (ronna . #e1e27)
+    (yotta . #e1e24)
+    (zetta . #e1e21)
+    (exa . #e1e18)
+    (peta . #e1e15)
+    (tera . #e1e12)
+    (giga . #e1e9)
+    (mega . #e1e6)
+    (kilo . #e1e3)
+    (hecto . #e1e2)
+    (deka . #e1e1)
+    (deci . #e1e-1)
+    (centi . #e1e-2)
+    (milli . #e1e-3)
+    (micro . #e1e-6)
+    (nano . #e1e-9)
+    (pico . #e1e-12)
+    (femto . #e1e-15)
+    (atto . #e1e-18)
+    (zepto . #e1e-21)
+    (yocto . #e1e-24)
+    (ronto . #e1e-27)
+    (quecto . #e1e-30)))
+
+(define *si-algebra*
+  `((/ . ,/)
+    (* . ,*)))
+
+(define (atom-d unit)
+  (after ((when (or (symbol? unit)
+                    (and (number? unit) (exact? unit)))))
+    unit))
+
+(define (prefixed-d unit)
+  (after ((let (length* unit 2) => (head unit))
+          (let (assq-d head *si-prefixes*) => (factor)))
+    (values factor unit)))
+
+(define (power-d unit)
+  (after ((let (length* unit 3) => (head number unit))
+          (when (eq? head '^)))
+    (values number unit)))
+
+(define (algebra-function-d unit)
+  (after ((let (length-at-least unit 3) => (head . rest))
+          (let (assq-d head *si-algebra*) => (procedure)))
+    (values head procedure rest)))
+
+(define (remove-prefixes unit)
+  (cond-values
+    (after ((let (atom-d unit) => (unit)))
+      (values 1 unit))
+    ;; 
+    (after ((let (prefixed-d unit) => (factor unit)))
+      (let-values (((sub-factor unit-w/o-factors)
+                    (remove-prefixes unit)))
+        (values (* sub-factor factor) unit-w/o-factors)))
+    ;; 
+    (after ((let (power-d unit) => (power unit)))
+      (let-values (((sub-factor sub-unit)
+                    (remove-prefixes unit)))
+        (values (expt sub-factor power)
+                (list '^ power sub-unit))))
+    ;; 
+    (after ((let (algebra-function-d unit) => (head proc units)))
+      (let-values (((factors units)
+                    (map-values remove-prefixes units)))
+        (values (apply proc factors)
+                (cons head units))))
+    (else (error "invalid unit" unit))))
+
+(remove-prefixes '(/ (* (centi meter) (centi meter))
+                     volt
+                     second))
+(remove-prefixes '(/ (^ 2 (centi meter))
+                     volt
+                     second))
+
+(define (make-unit-destructor atom prefixed power algebra-function on-else)
+  (lambda (unit)
+    (cond-values
+      (apply-after (atom-d unit) atom)
+      (apply-after (prefixed-d unit) prefixed)
+      (apply-after (power-d unit) power)
+      (apply-after (algebra-function-d unit) algebra-function)
+      (else (on-else unit)))))
+
+(import r7rs)
+
+(define (remove-prefixes unit)
+  (define (on-atom unit)
+    (values 1 unit))
+  (define (on-prefixed prefix-factor unit)
+    (let-values (((sub-prefix sub-unit) (remove-prefixes unit)))
+      (values (* prefix-factor sub-prefix) sub-unit)))
+  (define (on-power power unit)
+    (let-values (((sub-prefix sub-unit) (remove-prefixes unit)))
+      (values (expt sub-prefix power) sub-unit)))
+  (define (on-algebra-function symbol procedure units)
+    (let-values (((prefixes units) (map-values remove-prefixes units)))
+      (values (apply procedure prefixes)
+              (cons symbol units))))
+  (define (on-else unit)
+    (error "invalid unit" 'remove-prefixes unit))
+  (define remove-prefixes
+      (make-unit-destructor on-atom
+                            on-prefixed
+                            on-power
+                            on-algebra-function))
+  (remove-prefixes unit))
+
+(define remove-prefixes-destructors '())
+(define remove-prefixes-handlers '())
+
+(define (add-remove-prefixes-handler destructor handler)
+  (set! remove-prefixes-destructors
+        (cons destructor remove-prefixes-destructors))
+  (set! remove-prefixes-handlers
+        (cons handler remove-prefixes-handlers)))
+
+(define (remove-prefixes unit)
+  (cond-values
+    (any-values (lambda (destructor handler)
+                  (apply-after (destructor unit) handler))
+                remove-prefixes-destructors
+                remove-prefixes-handlers)
+    (else (error "invalid unit" unit))))
+
+(add-remove-prefixes-handler atom-d (lambda (unit)
+                                      (values 1 unit)))
+
+(remove-prefixes 'gram)
+(remove-prefixes '(kilo gram))
+
+(add-remove-prefixes-handler prefixed-d
+                             (lambda (factor unit)
+                               (let-values (((sub-factor sub-unit)
+                              (remove-prefixes unit)))
+                                 (values (* factor sub-factor) sub-unit))))
+
+(add-remove-prefixes-handler
+ algebra-function-d
+ (lambda (head procedure units)
+   (let-values (((factors units) (map-values remove-prefixes units)))
+     (values (apply procedure factors)
+             (cons head units)))))
+
+(remove-prefixes '(/ (kilo meter) (micro second)))
diff --git a/units.sml b/units.sml
new file mode 100644
index 0000000..0a821c1
--- /dev/null
+++ b/units.sml
@@ -0,0 +1,66 @@
+datatype si_prefix
+= QUETTA | RONNA | YOTTA | ZETTA | EXA | PETA | TERA | GIGA | MEGA
+| KILO | HECTO | DEKA | DECI | CENTI | MILLI | MICRO | NANO
+| PICO | FEMTO | ATTO | ZEPTO | YOCTO | RONTO | QUECTO;
+
+datatype si_function
+= DIVISION | MULT;
+
+datatype si_unit
+= UNIT of string
+| PREFIX of si_prefix * si_unit
+| ALGEBRA of si_function * si_unit list
+;
+
+fun factor_of_prefix QUETTA = 1e30
+  | factor_of_prefix RONNA = 1e27
+  | factor_of_prefix YOTTA = 1e24
+  | factor_of_prefix ZETTA = 1e21
+  | factor_of_prefix EXA = 1e18
+  | factor_of_prefix PETA = 1e15
+  | factor_of_prefix TERA = 1e12
+  | factor_of_prefix GIGA = 1e9
+  | factor_of_prefix MEGA = 1e6
+  | factor_of_prefix KILO = 1e3
+  | factor_of_prefix HECTO = 1e2
+  | factor_of_prefix DEKA = 1e1
+  | factor_of_prefix DECI = 1e~1
+  | factor_of_prefix CENTI = 1e~2
+  | factor_of_prefix MILLI = 1e~3
+  | factor_of_prefix MICRO = 1e~6
+  | factor_of_prefix NANO = 1e~9
+  | factor_of_prefix PICO = 1e~12
+  | factor_of_prefix FEMTO = 1e~15
+  | factor_of_prefix ATTO = 1e~18
+  | factor_of_prefix ZEPTO = 1e~21
+  | factor_of_prefix YOCTO = 1e~24
+  | factor_of_prefix RONTO = 1e~27
+  | factor_of_prefix QUECTO = 1e~30
+  ;
+
+fun apply_function DIVISION (head::[]) = head
+  | apply_function DIVISION [] = raise Match
+  | apply_function DIVISION (x::y::rest)
+    = apply_function DIVISION (x/y::rest)
+  | apply_function MULT [] = 1.0
+  | apply_function MULT (head::[]) = head
+  | apply_function MULT (x::y::rest)
+    = apply_function MULT (x*y::rest)
+  ;
+
+fun car (x,y) = x;
+fun cdr (x,y) = y;
+
+fun remove_prefixes (UNIT x) = (1e0, UNIT x)
+  | remove_prefixes (PREFIX (prefix, the_unit))
+    = let val (factor, sub_unit) = remove_prefixes the_unit
+      in (factor * (factor_of_prefix prefix), sub_unit)
+      end
+  | remove_prefixes (ALGEBRA (function, units))
+   = let val returned = map remove_prefixes units;
+         val factors = map car returned;
+         val units = map cdr returned;
+     in
+        (apply_function function factors, (ALGEBRA (function, units)))
+     end
+  ;