bachelor-cs/set-theory.lisp

   1 ;;;; Operations and definitions for Cantor and Dedekind's set theory.
   2
   3 (defpackage bachelor-cs.set-theory
   4   (:use :cl)
   5   (:export :Ø :∈ :⊆ :power :size :∪ :∩ :\\ :Δ :× :→))
   6
   7 (in-package :bachelor-cs.set-theory)
   8
   9 (defvar Ø '()
  10   "Empty set Ø")
  11
  12 ;;; Sets are represented either by a list or a predicate function.
  13
  14 (defgeneric ∈ (element set)
  15   (:documentation "Predicate to check if ELEMENT is in SET."))
  16
  17 (defmethod ∈ (element (set list))
  18   (not (null (member element set :test #'equal))))
  19
  20 (defmethod ∈ (element (set function))
  21   (funcall set element))
  22
  23 (defgeneric ⊆ (set-x set-y)
  24   (:documentation "Predicate to check if SET-X is a subset of SET-Y.
  25 Implemented only for SET-X represented as a list."))
  26
  27 (defmethod ⊆ ((set-x list) set-y)
  28   (null (loop for element in set-x
  29            unless (∈ element set-y) return t)))
  30
  31 (defmethod ⊆ (set-x (set-y list))
  32   (null (loop for element in set-y
  33            unless (∈ element set-x) return t)))
  34
  35 (defun power (set)
  36   "Returns the power of SET."
  37   (lambda (element)
  38     (or (equal element Ø)
  39         (⊆ element set))))
  40
  41 (defgeneric size (set)
  42   (:documentation "Returns cardinality of SET (usually |set|). Only
  43 implemented for SET represented as a list."))
  44
  45 (defmethod size ((set list))
  46   (length set))
  47
  48 (defmethod size ((set function))
  49   :∞)
  50
  51 (defgeneric ∪-2 (set-x set-y)
  52   (:documentation "Union of SET-X and SET-Y."))
  53
  54 (defmethod ∪-2 ((set-x list) (set-y list))
  55   (remove-duplicates (append set-x set-y)
  56                      :test #'equal))
  57
  58 (defmethod ∪-2 (set-x set-y)
  59   (lambda (element)
  60     (or (∈ element set-x)
  61         (∈ element set-y))))
  62
  63 (defun ∪ (&rest sets)
  64   "Union of SETS."
  65   (reduce #'∪-2 sets))
  66
  67 (defgeneric ∩-2 (set-x set-y)
  68   (:documentation "Intersection of SET-X and SET-Y."))
  69
  70 (defmethod ∩-2 ((set-x list) (set-y list))
  71   (intersection set-x set-y :test #'equal))
  72
  73 (defmethod ∩-2 ((set-x list) set-y)
  74   (loop for element in set-x
  75      when (∈ element set-y) collect element))
  76
  77 (defmethod ∩-2 (set-x (set-y list))
  78   (loop for element in set-y
  79      when (∈ element set-x) collect element))
  80
  81 (defmethod ∩-2 (set-x set-y)
  82   (lambda (element)
  83     (and (∈ element set-x)
  84          (∈ element set-y))))
  85
  86 (defun ∩ (&rest sets)
  87   "Intersection of SETS."
  88   (reduce #'∩-2 sets))
  89
  90 (defgeneric \\-2 (set-x set-y)
  91   (:documentation "Subtracts SET-Y from SET-X."))
  92
  93 (defmethod \\-2 ((set-x list) set-y)
  94   (remove-if (lambda (element) (∈ element set-y))
  95              set-x))
  96
  97 (defmethod \\-2 (set-x (set-y list))
  98   (remove-if (lambda (element) (∈ element set-x))
  99              set-y))
 100
 101 (defmethod \\-2 (set-x set-y)
 102   (lambda (element)
 103     (and (∈ element set-x)
 104          (not (∈ element set-y)))))
 105
 106 (defun \\ (&rest sets)
 107   "Subtracts SETS."
 108   (reduce #'\\-2 sets))
 109
 110 (defun Δ-2 (set-x set-y)
 111   "Symmetric difference for SET-X and SET-Y."
 112   (∪ (\\ set-x set-y) (\\ set-y set-x)))
 113
 114 (defun Δ (&rest sets)
 115   "Symmetric difference for SETS."
 116   (reduce #'Δ-2 sets))
 117
 118 (defgeneric ×-2 (set-x set-y)
 119   (:documentation "Cartesian product of SET-X and SET-Y."))
 120
 121 (defmethod ×-2 ((set-x list) (set-y list))
 122   (remove-duplicates
 123    (loop for element-x in set-x append
 124         (loop for element-y in set-y collect
 125              (list element-x element-y)))
 126    :test #'equal))
 127
 128 (defmethod ×-2 (set-x set-y)
 129   (lambda (element)
 130     (and (∈ (first element) set-x)
 131          (∈ (second element) set-y))))
 132
 133 (defun × (&rest sets)
 134   "Cartesian product of SETS."
 135   (remove-duplicates
 136    (labels ((tuple (product)
 137               (dotimes (i (- (length sets) 2))
 138                 (setf product (append (car product)
 139                                       (cdr product))))
 140               product))
 141      (loop for product in (reduce #'×-2 sets)
 142         collect (tuple product)))
 143    :test #'equal))
 144
 145 (defmacro → (args &rest body)
 146   "Return a function that takes one argument, destructures it accoring to
 147 ARGS and then evaluates BODY."
 148   (let ((g!element (gensym "element")))
 149     `(lambda (,g!element)
 150        (destructuring-bind ,args ,g!element
 151          ,@body))))