gnu.scm 2.3 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566
  1. ;; Copyright (C) 2020 Free Software Foundation, Inc.
  2. ;;
  3. ;; This library is free software; you can redistribute it and/or
  4. ;; modify it under the terms of the GNU Lesser General Public
  5. ;; License as published by the Free Software Foundation; either
  6. ;; version 3 of the License, or (at your option) any later version.
  7. ;;
  8. ;; This library is distributed in the hope that it will be useful,
  9. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  10. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
  11. ;; Lesser General Public License for more details.
  12. ;;
  13. ;; You should have received a copy of the GNU Lesser General Public
  14. ;; License along with this library; if not, write to the Free Software
  15. ;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  16. (define-module (srfi srfi-171 gnu)
  17. #:use-module (srfi srfi-171)
  18. #:use-module (srfi srfi-171 meta)
  19. #:export (tbatch tfold))
  20. (define tbatch
  21. (case-lambda
  22. ((reducer)
  23. (tbatch identity reducer))
  24. ((t r)
  25. (lambda (reducer)
  26. (let ((cur-reducer (t r))
  27. (cur-state (r)))
  28. (case-lambda
  29. (() (reducer))
  30. ((result)
  31. (if (equal? cur-state (cur-reducer))
  32. (reducer result)
  33. (let ((new-res (reducer result (cur-reducer cur-state))))
  34. (if (reduced? new-res)
  35. (reducer (unreduce new-res))
  36. (reducer new-res)))))
  37. ((result value)
  38. (let ((val (cur-reducer cur-state value)))
  39. (cond
  40. ;; cur-reducer is done. Push value downstream
  41. ;; re-instantiate the state and the cur-reducer
  42. ((reduced? val)
  43. (let ((unreduced-val (unreduce val)))
  44. (set! cur-reducer (t r))
  45. (set! cur-state (cur-reducer))
  46. (reducer result (cur-reducer unreduced-val))))
  47. (else
  48. (set! cur-state val)
  49. result))))))))))
  50. (define* (tfold reducer #:optional (seed (reducer)))
  51. (lambda (r)
  52. (let ((state seed))
  53. (case-lambda
  54. (() (r))
  55. ((result) (r result))
  56. ((result value)
  57. (set! state (reducer state value))
  58. (if (reduced? state)
  59. (reduced (reducer (unreduce state)))
  60. (r result state)))))))