From 0082ed981eaafa77c2be87cb6000151b40d085f8 Mon Sep 17 00:00:00 2001 From: "Edward L. Platt" Date: Mon, 24 Oct 2022 09:45:49 -0400 Subject: [PATCH] Refactor preference module to improve consistency. --- deliberate/preference.scm | 121 ++++++++++++++++++++++++++++++++++++++ tests/test-preference.scm | 102 ++++++++++++++++++++++++++++++++ 2 files changed, 223 insertions(+) create mode 100644 deliberate/preference.scm create mode 100644 tests/test-preference.scm diff --git a/deliberate/preference.scm b/deliberate/preference.scm new file mode 100644 index 0000000..bbb65a6 --- /dev/null +++ b/deliberate/preference.scm @@ -0,0 +1,121 @@ +;;; Copyright 2022 Edward L. Platt +;;; +;;; 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. + +(define-module (deliberate preference) + #:use-module (srfi srfi-1) + #:use-module (goblins) + #:use-module (goblins vrun) + #:use-module (goblins actor-lib methods) + #:use-module (deliberate utils) + #:export (^alternatives ^ranked-preference ^ranked-profile)) + +;; Constructor for ^alternatives +;; A set of alternative outcomes to a question. +;; +;; Parameters: +;; question: String describing the question being considered +;; alternatives: list of strings describing possible alternatives +;; +;; Messages: +;; question: Return the question string +;; alternatives: Return the current list of alternatives +;; add-alternative: Add an alternative to the list +;; +(define (^alternatives bcom question alternatives) + (define alts-cell (spawn ^cell alternatives)) + (methods + ((question) question) + ((alternatives) ($ alts-cell 'get)) + ((add alt) + ($ alts-cell 'set (cons alt ($ alts-cell 'get)))) + )) + +;; Constructor for ^ranked-preference +;; One constituent's preferences as an ordered ranking. +;; +;; Preferences model a single constituent's preference on a specific question. +;; Ranked preferenes model constituent preferences as an ordered relationship +;; between a finite list of possible alternatives. +;; +;; ^ranked-preference is associated with a set of alternatives at creation. +;; The initial ranking is empty. +;; +;; Preferences are updated by passing a function mapping alternatives to +;; their ranks, which ensures consistency between the alternatives and the +;; elements of the ranking. +;; +;; Parameters: +;; alternatives: An ^alternatives object +;; +;; Messages: +;; ranked: Return the ranked list of alternatives +;; rank-of alternative: Return the rank of alternative (1 is most +;; preferred) or #f if not present in the ranking +;; set f: Update the ranking according to a function mapping alternatives +;; to their rank position. +;; +(define (^ranked-preference _bcom alternatives) + (define ranking (spawn ^cell '())) + (methods + ((ranked) ($ ranking 'get)) + ((rank-of alternative) + (let ((alt-index + (list-index + (lambda (alt) (equal? alt alternative)) + ($ ranking 'get)))) + (if (number? alt-index) + (+ 1 alt-index) + #f))) + ((set f) + (let* ((alt-list ($ alternatives 'alternatives)) + (ranks (f alt-list)) + (new-ranking (reorder alt-list ranks))) + ($ ranking 'set new-ranking))) + )) + +;; Constructor for ^ranked-profile +;; A preference profile for ordered rankings. +;; +;; Preference profiles represent the preferences of a group of constituents +;; on a specific question. Ranked preferences model constituent preferences as +;; an ordered relationships between a finite list of possible alternatives. +;; +;; Parameters: +;; alternatives: An ^alternatives object +;; +;; Messages: +;; add-preference: Create and track a new ^ranked-preference as part of this +;; profile. The new object is returned. +;; counts: Returns a list representing all preference rankings in the +;; profile. The list is of the form: +;; ((`ranking-1` . `count-1`) (`ranking-2` . `count-2`) ...) +;; where `ranking-n` is a list of strings, and `count-n` is the number +;; of times that ranking appears in this profile. +;; +(define (^ranked-profile _bcom alternatives) + (define preferences (spawn ^cell '())) + (methods + ((add-preference) + (let ((pref (spawn ^ranked-preference alternatives))) + ($ preferences 'set (cons pref ($ preferences 'get))) + pref)) + ((counts) + (let ((rankings (map (lambda (pref) ($ pref 'ranked)) + ($ preferences 'get)))) + ;; This is an inefficent represntation but OK for now + ;; (( . 1) ( . 1) ...) + (map cons rankings (const-list (length rankings) 1)))) + )) + + diff --git a/tests/test-preference.scm b/tests/test-preference.scm new file mode 100644 index 0000000..5db81ce --- /dev/null +++ b/tests/test-preference.scm @@ -0,0 +1,102 @@ +;;; Copyright 2022 Edward L. Platt +;;; +;;; 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. + +(define-module (tests test-preference) + #:use-module (srfi srfi-64) + #:use-module (goblins) + #:use-module (goblins vrun) + #:use-module (goblins actor-lib methods) + #:use-module (deliberate preference)) + +(test-begin "test-deliberate-preference") + +(define a-vat (spawn-vat)) +(define-vat-run a-run a-vat) + +;; Tests for ^alternatives +(define question "What type of generator should we install?") +(define alts (a-run (spawn ^alternatives question '("solar" "wind")))) + +(test-equal "What type of generator should we install?" + (a-run ($ alts 'question))) + +(test-equal '("solar" "wind") + (a-run ($ alts 'alternatives))) + +(a-run ($ alts 'add "hydro")) + +(test-equal '("hydro" "solar" "wind") + (a-run ($ alts 'alternatives))) + + +;; Tests for ^ranked-preference +(define alternatives + (a-run (spawn ^alternatives + question + '("solar" "wind" "hydro")))) +(define (f1 alts) '(1 2 3)) +(define (f2 alts) '(2 3 1)) + +(define pref (a-run (spawn ^ranked-preference alternatives))) + +(test-equal '() + (a-run ($ pref 'ranked))) + +(test-equal #f + (a-run ($ pref 'rank-of "solar"))) + +(a-run ($ pref 'set f1)) + +(test-equal 1 + (a-run ($ pref 'rank-of "solar"))) + +(test-equal 3 + (a-run ($ pref 'rank-of "hydro"))) + +(test-equal #f + (a-run ($ pref 'rank-of "wildgoose"))) + +(a-run ($ pref 'set f2)) + +(test-equal 1 + (a-run ($ pref 'rank-of "hydro"))) + + +;; Tests for ^ranked-profile +(define profile (a-run (spawn ^ranked-profile alternatives))) +(define pref1 (a-run ($ profile 'add-preference))) + +(test-equal '() + (a-run ($ pref1 'ranked))) + +(define pref2 (a-run ($ profile 'add-preference))) +(a-run ($ pref1 'set f1)) +(a-run ($ pref2 'set f2)) + +(define counts (a-run ($ profile 'counts))) + +(test-equal '((("hydro" "solar" "wind") . 1) + (("solar" "wind" "hydro") . 1)) + counts) + +(test-equal '("hydro" "solar" "wind") + (car (car counts))) + +(test-equal 1 + (cdr (car counts))) + +(test-equal '("solar" "wind" "hydro") + (car (cadr counts))) + +(test-end "test-deliberate-preference")