dds/functions.rkt

#lang racket

;;; dds/functions

;;; This modules provides some definitions for working with functions:
;;; tabulating, (re)constructing from tables, generating random
;;; functions, etc.  Some definitions of particular kinds of functions
;;; are also provided (threshold Boolean functions, etc.).

(require "utils.rkt")

(provide
 ;; Structures
 (contract-out
  [struct tbf ((weights number?) (threshold (vectorof number?)))])
 ;; Functions
 (contract-out
  [tabulate (-> procedure? (listof generic-set?) (listof list?))]
  [tabulate* (-> (listof procedure?) (listof generic-set?) (listof list?))]
  [tabulate/boolean (-> procedure-fixed-arity? (listof (listof boolean?)))]
  [tabulate*/boolean (-> (non-empty-listof procedure?) (listof list?))]
  [table->function (-> (listof (*list/c any/c any/c)) procedure?)]
  [table->function/list (-> (listof (*list/c any/c any/c)) procedure?)]
  [enumerate-boolean-tables (-> number? (stream/c (listof (*list/c boolean? boolean?))))]
  [enumerate-boolean-functions (-> number? (stream/c procedure?))]
  [enumerate-boolean-functions/list (-> number? (stream/c procedure?))]
  [random-boolean-table (-> number? (listof (*list/c boolean? boolean?)))]
  [random-boolean-function (-> number? procedure?)]
  [random-boolean-function/list (-> number? procedure?)]
  [tbf-w (-> tbf? (vectorof number?))]
  [tbf-θ (-> tbf? number?)]))

(module+ test
  (require rackunit))


;;; ==========
;;; Tabulating
;;; ==========

;;; Given a function and a list of domains for each of its arguments,
;;; in order, produces a list of lists giving the values of arguments
;;; and the value of the functions for these inputs.
(define (tabulate func doms)
  (tabulate* `(,func) doms))

(module+ test
  (test-case "tabulate"
    (check-equal? (tabulate (λ (x y) (and x y)) '((#f #t) (#f #t)))
                  '((#f #f #f) (#f #t #f) (#t #f #f) (#t #t #t)))))

;;; Like tabulate, but takes a list of functions taking
;;; the same arguments over the same domains.
(define (tabulate* funcs doms)
  (for/list ([xs (apply cartesian-product doms)])
    (append xs (for/list ([f funcs]) (apply f xs)))))

(module+ test
  (test-case "tabulate*"
    (check-equal? (tabulate* (list (λ (x y) (and x y))
                                   (λ (x y) (or x y)))
                             '((#f #t) (#f #t)))
                  '((#f #f #f #f) (#f #t #f #t) (#t #f #f #t) (#t #t #t #t)))
    (check-equal? (tabulate* empty '((#f #t) (#f #t)))
                  '((#f #f) (#f #t) (#t #f) (#t #t)))))

;;; Like tabulate, but assumes the domains of all variables of the
;;; function are Boolean.  func must have a fixed arity.  It is an
;;; error to supply a function of variable arity.
(define (tabulate/boolean func)
  (tabulate func (make-list (procedure-arity func) '(#f #t))))

(module+ test
  (test-case "tabulate/boolean"
    (check-equal? (tabulate/boolean (lambda (x y) (and x y)))
                  '((#f #f #f) (#f #t #f) (#t #f #f) (#t #t #t)))))

;;; Like tabulate/boolean, but takes a list of functions of the same
;;; arity.
(define (tabulate*/boolean funcs)
  (define doms (make-list (procedure-arity (car funcs)) '(#f #t)))
  (tabulate* funcs doms))

(module+ test
  (test-case "tabulate*/boolean"
    (check-equal? (tabulate*/boolean `(,(λ (x y) (and x y))
                                       ,(λ (x y) (or x y))))
                  '((#f #f #f #f) (#f #t #f #t) (#t #f #f #t) (#t #t #t #t)))))


;;; ======================
;;; Constructing functions
;;; ======================

;;; Given a table like the one produced by the tabulate functions,
;;; creates a function which has this behaviour.
;;;
;;; More exactly, the input is a list of lists of values.  All but the
;;; last elements of every list give the values of the parameters of
;;; the function, while the the last element of every list gives the
;;; value of the function.  Thus, every list should have at least two
;;; elements.
;;;
;;; The produced function is implemented via lookups in hash tables,
;;; meaning that it may be sometimes more expensive to compute than by
;;; using an direct symbolic implementation.
(define (table->function table)
  (let ([func (table->function/list table)])
    (λ args (func args))))

(module+ test
  (test-case "table->function"
    (define negation (table->function '((#t #f) (#f #t))))
    (check-true (negation #f))
    (check-false (negation #t))))

;;; Like table->function, but the produced function accepts a single
;;; list of arguments instead of individual arguments.
(define (table->function/list table)
  ((curry hash-ref)
   (for/hash ([line table])
     (let-values ([(x fx) (split-at-right line 1)])
       (values x (car fx))))))

(module+ test
  (test-case "table->function/list"
    (define negation/list (table->function/list '((#t #f) (#f #t))))
    (check-true (negation/list '(#f)))
    (check-false (negation/list '(#t)))))

;;; Returns the stream of the truth tables of all Boolean functions of
;;; a given arity.
;;;
;;; There are 2^(2^n) Boolean functions of arity n.
(define (enumerate-boolean-tables n)
  (let ([inputs (boolean-power/stream n)]
        [outputs (boolean-power/stream (expt 2 n))])
    (for/stream ([out (in-stream outputs)])
      (for/list ([in (in-stream inputs)] [o out])
        (append in (list o))))))

;;; Returns the stream of all Boolean functions of a given arity.
;;;
;;; There are 2^(2^n) Boolean functions of arity n.
(define (enumerate-boolean-functions n)
  (stream-map table->function (enumerate-boolean-tables n)))

(module+ test
  (test-case "enumerate-boolean-tables"
    (define f1 (stream-first (enumerate-boolean-functions 1)))
    (check-false (f1 #f))
    (check-false (f1 #t))))

;;; Returns the stream of all Boolean functions of a given arity.  As
;;; different from the functions returned by
;;; enumerate-boolean-functions, the functions take lists of arguments
;;; instead of n arguments.
;;;
;;; There are 2^(2^n) Boolean functions of arity n.
(define (enumerate-boolean-functions/list n)
  (stream-map table->function/list (enumerate-boolean-tables n)))

(module+ test
  (test-case "enumerate-boolean-functions/list"
    (define f1/list (stream-first (enumerate-boolean-functions/list 1)))
    (check-false (f1/list '(#f)))
    (check-false (f1/list '(#t)))))


;;; ================
;;; Random functions
;;; ================

;;; Generates a random truth table for a Boolean function of arity n.
(define (random-boolean-table n)
  (define/match (num->bool x) [(0) #f] [(1) #t])
  (define inputs (boolean-power n))
  (define outputs (stream-take (in-random 2) (expt 2 n)))
  (for/list ([i inputs] [o outputs])
    (append i (list (num->bool o)))))

(module+ test
  (test-case "random-boolean-table"
    (random-seed 0)
    (check-equal? (random-boolean-table 2) '((#f #f #t) (#f #t #t) (#t #f #f) (#t #t #f)))))

;;; Generates a random Boolean function of arity n.
(define random-boolean-function (compose table->function random-boolean-table))

(module+ test
  (test-case "random-boolean-function"
    (define f (random-boolean-function 2))
    (check-true (f #f #f)) (check-false (f #f #t))
    (check-true (f #t #f)) (check-false (f #t #t))))

;;; Like random-boolean-function, but the constructed function takes a
;;; list of arguments.
(define random-boolean-function/list (compose table->function/list random-boolean-table))

(module+ test
  (test-case "random-boolean-function/list"
    (define f (random-boolean-function/list 2))
    (check-false (f '(#f #f))) (check-true (f '(#f #t)))
    (check-true (f '(#t #f))) (check-false (f '(#t #t)))))


;;; ===========================
;;; Threshold Boolean functions
;;; ===========================

;;; A threshold Boolean function (TBF) is a pair (w, θ), where w is a
;;; vector of weights and θ is the threshold.
(struct tbf (weights threshold) #:transparent)

;;; Unicode shortcuts for accessing the elements of a TBF.
(define tbf-w tbf-weights)
(define tbf-θ tbf-threshold)