A collection of list oriented procedures for the slope programming language
You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.

208 lines
8.3 KiB

;;;
;;; list - a collection of list oriented procedures
;;; Author: sloum
;;; Version: 0.1.2
;;;
;;
;; reduce performs a left associative reduce
;;
;; (list::reduce [procedure] [list] [initial: value]) => value
;;
;; ex: (reduce + [1 2 3 4] 0) => 10
(define reduce (lambda (proc lst init)
(cond
((not (procedure? proc))
(! "'reduce' expected a procedure as its first argument, a non-procedure value was given"))
((not (list? lst))
(! "'reduce' expected a list as its second argument, a non-list value was given"))
(else (begin
(define reduce-loop (lambda (p l i)
(if (null? l)
i
(reduce-loop p (cdr l) (p i (car l))))))
(reduce-loop proc lst init))))))
;;
;; last retrieves the last element of a list
;;
;; (list::last [list]) => value
;;
;; ex: (last [1 'A "Hi"]) => "Hi"
;;
(define last (lambda (lst)
(cond
((list? lst) (if (null? lst)
(! "'last' was given a null list, there is no last element")
(list-ref lst (- (length lst) 1))))
((string? lst) (if (equal? lst "")
(! "'last' was given an empty string, there is no last element")
(string-ref lst (- (length lst) 1))))
(else (! "'last' expected a list or a string, but a non-string non-list value was given")))))
;;
;; find retrieves the first or last value that returns
;; a truthy value when passed to a predicate procedure
;;
;; (list::find [procedure] [list] [[last: bool]] [[nomatch]]) => value
;;
;; - 'last' defaults to: #f and determines whether to use the
;; last matching value rather than the first (default)
;; - 'nomatch' defaults to #f, but can be set to any value,
;; which will be returned if there are no values that
;; return a truthy value from the predicate procedure
;;
;; ex: (list::find (lambda (x) (> x 50)) [53 43 87]) => 53
;; (list::find (lambda (x) (> x 50)) [53 43 87] #t) => 87
;; (list::find (lambda (x) (> x 90)) [53 43 87]) => #f
;; (list::find (lambda (x) (> x 90)) [53 43 87] #f 0) => 0
;;
(define find (lambda (proc lst args-list)
(cond
((not (procedure? proc))
(! "'find' expected a procedure as its first argument, a non-procedure value was given"))
((not (list? lst))
(! "'find' expected a list as its second argument, a non-list value was given"))
(else (begin
; Reverse the list if looking for the last element
(if (and (> (length args-list) 0) (car args-list))
(set! lst (reverse lst)))
; Define the nomatch to given value or to #f if no given value
(define nomatch (if (> (length args-list) 1)
(car (cdr args-list))
#f))
; Create a recursive loop searching for the value
(define find-loop (lambda (proc lst nomatch)
(cond
((null? lst) nomatch)
((proc (car lst)) (car lst))
(else (find-loop proc (cdr lst) nomatch)))))
; Perform the search
(find-loop proc lst nomatch))))))
;;
;; position retrieves the first or last list index that returns
;; a truthy value when the index's value is passed to a predicate
;; given procedure
;;
;; (list::position [procedure] [list] [[last: bool]] [[nomatch]]) => value
;;
;; - 'last' defaults to: #f and determines whether to use the
;; last matching value rather than the first (default)
;; - 'nomatch' defaults to #f, but can be set to any value,
;; which will be returned if there are no values that
;; return a truthy value from the predicate procedure
;;
;; ex: (list::position (lambda (x) (> x 5)) [5 7 4 8]) => 1
;; (list::position (lambda (x) (> x 5)) [5 7 4 8] #t) => 3
;; (list::position (lambda (x) (> x 9)) [5 4 8]) => #f
;; (list::position (lambda (x) (> x 9)) [5 4 8] #f -1) => -1
;;
(define position (lambda (proc lst args-list)
(cond
((not (procedure? proc))
(! "'position' expected a procedure as its first argument, a non-procedure value was given"))
((not (list? lst))
(! "'position' expected a list as its second argument, a non-list value was given"))
(else
(begin
(define last #f)
; Reverse the list if looking for the last element
(if (and (> (length args-list) 0) (car args-list))
(begin (set! lst (reverse lst)) (set! last #t)))
; Define the nomatch to given value or to #f if no given value
(define nomatch (if (> (length args-list) 1)
(car (cdr args-list))
#f))
; Create a recursive loop searching for the value
(define position-loop (lambda (proc l nomatch pos)
(set! pos (+ pos 1))
(cond
((null? l) nomatch)
((proc (car l)) (if last (- (length lst) pos 1) pos))
(else (position-loop proc (cdr l) nomatch pos)))))
; Perform the search
(position-loop proc lst nomatch -1))))))
;;
;; unique creates a set/unique-list from a given list
;;
;; (list::unique [list]) => list
;;
;; ex: (list::unique [1 1 22 4 3 1 3 3 4]) => [1 22 4 3]
;;
(define unique (lambda (lst)
(if (not (list? lst))
(! "'unique' expected a list, a non-list value was given")
(begin
(define out [])
(for-each (lambda (i)
(if (not (member? out i))
(set! out (cons i out)))) lst)
(reverse out)))))
;;
;; cadr returns the car of the cdr of a list
;;
;; (list::cadr [list]) => value
;;
;; ex: (list::cadr [1 2 3 4]) => 2
;; (list::cadr [[1 'A] [2 'B] [3 'C]]) => (2 'B)
;;
(define cadr (lambda (lst)
(cond
((not (list? lst))
(! "'cadr' expected a list, a non-list value was given"))
((< (length lst) 2)
(! "'cadr' was given a list with too few values"))
(else
(car (cdr lst))))))
;;
;; alike returns a boolean representing whether or not
;; the items in the list are of the same type
;;
;; (list::alike? [list]) => bool
;;
;; ex: (list::alike? [1 2 3 4]) => #t
;; (list::alike? [1 2 "3" 4]) => #f
;; (list::alike? [[1 2] ["a" "b"] []]) => #t
;; (list::alike? []) => #t
;;
;; - A null list returns #t
;; - Sublists are not evaluated, if all items in a list
;; are also lists, #t is returned, regardless of what
;; those lists contain
;;
(define alike? (lambda (l)
(cond
((not (list? l))
(! "'alike?' expected a list, a non-list value was given"))
((null? l)
#t)
(else (begin
(define alike-loop (lambda (lst typ)
(cond
((null? lst) #t)
((not (equal? (type (car lst)) typ)) #f)
(else (alike-loop (cdr lst) typ)))))
(alike-loop l (type (car l))))))))
(define _USAGE [
["reduce" "(list::reduce [procedure] [list] [init: value]) => value\n\n`reduce`. This version of reduce is left associative and was added to this module before `reduce` was present in the std library. It remains here for historical reasons, but the builtin should be favored."]
["last" "(list::last [list]) => value\n\n`last` retrieves the last value in the list, and is thus the opposite of the built-in `car`"]
["find" "(list::find [procedure] [list] [[last?: bool]] [[nomatch: value]]) => number|nomatch: value\n\n`find` retrieves the first, or last, list value that returns `#t` when pased to a predicate procedure.\n\n`last?` defaults to `#f`, thus returning the first truthy value. A `#t` setting for `last?` will return the last truthy value (it will make the procedure right associative).\n\n`nomatch` defines the value to be returned if no list values are found to be truthy. The default `nomatch` value is `#f`."]
["position" "(list::position [procedure] [list] [[last?: bool]] [[nomatch: value]]) => number|nomatch: value\n\n`position` retrieves the first, or last, list index that returns `#t` when pased to a predicate procedure.\n\n`last?` defaults to `#f`, thus returning the first truthy value. A `#t` setting for `last?` will return the last truthy value (it will make the procedure right associative).\n\n`nomatch` defines the value to be returned if no list values are found to be truthy. The default `nomatch` value is `#f`."]
["unique" "(list::unique [list]) => list\n\n`unique` returns a set/unique-list from the given list"]
["cadr" "(list::cadr [list]) => value\n\n`cadr` returns the car of the cdr of the given list"]
["alike?" "(list::alike [list]) => bool\n\n`alike?` returns a boolean representing whether or not the items in the list are of the same type"]])
; vim: ts=2 sw=2 expandtab ft=slope