|
| 1 | +;;; SRFI 161 |
| 2 | +;;; Unifiable Boxes |
| 3 | +;;; |
| 4 | +;;; Unifiable boxes are, like the boxes of SRFI 111, objects with a single mutable state. |
| 5 | +;;; A constructor, predicate, accessor, and mutator are provided. |
| 6 | +;;; In addition to the state, an equality predicate and union operations (link, union, unify) |
| 7 | +;;; are provided. Applying a union operation to two unifiable boxes makes the two boxes equal |
| 8 | +;;; (in the sense of the equality predicate). As a consequence, their state will also become |
| 9 | +;;; identical. In the case of link and union, it will be the state of one of the two unioned |
| 10 | +;;; boxes. In the case of unify, the state is determined by a supplied unification procedure. |
| 11 | +;;; |
| 12 | +;;; Copyright (C) Marc Nieper-Wißkirchen (2018). All Rights Reserved. |
| 13 | +;;; |
| 14 | +;;; Permission is hereby granted, free of charge, to any person obtaining a copy of this |
| 15 | +;;; software and associated documentation files (the "Software"), to deal in the Software |
| 16 | +;;; without restriction, including without limitation the rights to use, copy, modify, merge, |
| 17 | +;;; publish, distribute, sublicense, and/or sell copies of the Software, and to permit |
| 18 | +;;; persons to whom the Software is furnished to do so, subject to the following conditions: |
| 19 | +;;; |
| 20 | +;;; The above copyright notice and this permission notice shall be included in all copies or |
| 21 | +;;; substantial portions of the Software. |
| 22 | +;;; |
| 23 | +;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, |
| 24 | +;;; INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A |
| 25 | +;;; PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT |
| 26 | +;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF |
| 27 | +;;; CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE |
| 28 | +;;; OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. |
| 29 | +;;; |
| 30 | +;;; LispKit Port: |
| 31 | +;;; Copyright © 2018 Matthias Zenger. All rights reserved. |
| 32 | + |
| 33 | +(define-library (srfi 161) |
| 34 | + |
| 35 | + (export ubox |
| 36 | + ubox? |
| 37 | + ubox-ref |
| 38 | + ubox-set! |
| 39 | + ubox=? |
| 40 | + ubox-unify! |
| 41 | + ubox-union! |
| 42 | + ubox-link!) |
| 43 | + |
| 44 | + (import (lispkit base)) |
| 45 | + |
| 46 | + (begin |
| 47 | + (define-record-type <ubox> |
| 48 | + (make-ubox parent rank value) |
| 49 | + ubox? |
| 50 | + (parent ubox-parent ubox-set-parent!) |
| 51 | + (rank ubox-rank ubox-set-rank!) |
| 52 | + (value ubox-value ubox-set-value!)) |
| 53 | + |
| 54 | + (define (ubox-find ubox) |
| 55 | + (let ((parent (ubox-parent ubox))) |
| 56 | + (if parent |
| 57 | + (let ((root (ubox-find parent))) |
| 58 | + (ubox-set-parent! ubox root) |
| 59 | + root) |
| 60 | + ubox))) |
| 61 | + |
| 62 | + (define (ubox value) |
| 63 | + (make-ubox #f 0 value)) |
| 64 | + |
| 65 | + (define (ubox-ref ubox) |
| 66 | + (ubox-value (ubox-find ubox))) |
| 67 | + |
| 68 | + (define (ubox-set! ubox val) |
| 69 | + (ubox-set-value! (ubox-find ubox) val)) |
| 70 | + |
| 71 | + (define (ubox=? ubox1 ubox2) |
| 72 | + (eq? (ubox-find ubox1) (ubox-find ubox2))) |
| 73 | + |
| 74 | + (define (ubox-unify! proc ubox1 ubox2) |
| 75 | + (let ((value (proc (ubox-ref ubox1) (ubox-ref ubox2)))) |
| 76 | + (ubox-union! ubox1 ubox2) |
| 77 | + (ubox-set! ubox1 value))) |
| 78 | + |
| 79 | + (define (ubox-union! ubox1 ubox2) |
| 80 | + (let ((root1 (ubox-find ubox1)) |
| 81 | + (root2 (ubox-find ubox2))) |
| 82 | + (unless (eq? root1 root2) |
| 83 | + (cond ((< (ubox-rank root1) (ubox-rank root2)) |
| 84 | + (ubox-set-parent! root1 root2) |
| 85 | + (ubox-set-value! root1 #f) |
| 86 | + (ubox-set-rank! root1 #f)) |
| 87 | + (else |
| 88 | + (when (= (ubox-rank root1) (ubox-rank root2)) |
| 89 | + (ubox-set-rank! root1 (+ (ubox-rank root1) 1))) |
| 90 | + (ubox-set-parent! root2 root1) |
| 91 | + (ubox-set-value! root2 #f) |
| 92 | + (ubox-set-rank! root2 #f)))))) |
| 93 | + |
| 94 | + (define (ubox-link! ubox1 ubox2) |
| 95 | + (ubox-unify! (lambda (x y) y) ubox1 ubox2)) |
| 96 | + ) |
| 97 | +) |
| 98 | + |
0 commit comments