hellerve/dotfiles
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Added cabal and vim dir

Browse Source
This commit is contained in:
hellerve
2015-04-05 17:47:08 +02:00
parent 1e73d5652c
commit ae5a30a4a4
2440 changed files with 40465 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

22
cabal/share/x86_64-osx-ghc-7.8.4/zepto-0.6.2/stdlib/char.scm Normal file
View File

@@ -0,0 +1,22 @@
(define (char-cmp? cmp a b) "compares two chars with a compare option cmp"
(cmp (char->integer a) (char->integer b)))
(define (char-ci-cmp? cmp a b) "compares two chars case insensitive with a compare option cmp"
(cmp (char->integer (char-downcase a)) (char->integer (char-downcase b))))
(define (char=? a b) "are chars equal" (char-cmp? = a b))
(define (char<? a b) "is char less than" (char-cmp? < a b))
(define (char>? a b) "is char greater than" (char-cmp? > a b))
(define (char<=? a b) "is char less than or equal to" (char-cmp? <= a b))
(define (char>=? a b) "is char greater than or equal to" (char-cmp? >= a b))
(define (char-ci=? a b) "are chars equal; case insensitive"
(char-ci-cmp? = a b))
(define (char-ci<? a b) "is char less than; case insensitive"
(char-ci-cmp? < a b))
(define (char-ci>? a b) "is char greater than; case insensitive"
(char-ci-cmp? > a b))
(define (char-ci<=? a b) "is char less than or equal to; case insensitive"
(char-ci-cmp? <= a b))
(define (char-ci>=? a b) "is char greater than or equal to; case insensitive"
(char-ci-cmp? >= a b))

316
cabal/share/x86_64-osx-ghc-7.8.4/zepto-0.6.2/stdlib/comlist.scm Normal file
View File

@@ -0,0 +1,316 @@
;;"comlist.scm" Implementation of COMMON LISP list functions for Scheme
; Copyright (C) 1991, 1993, 1995, 2001, 2003 Aubrey Jaffer.
; Copyright (C) 2000 Colin Walters
;
;Permission to copy this software, to modify it, to redistribute it,
;to distribute modified versions, and to use it for any purpose is
;granted, subject to the following restrictions and understandings.
;
;1. Any copy made of this software must include this copyright notice
;in full.
;
;2. I have made no warranty or representation that the operation of
;this software will be error-free, and I am under no obligation to
;provide any services, by way of maintenance, update, or otherwise.
;
;3. In conjunction with products arising from the use of this
;material, there shall be no use of my name in any advertising,
;promotional, or sales literature without prior written consent in
;each case.
;;; Some of these functions may be already defined in your Scheme.
;;; Comment out those definitions for functions which are already defined.
;;;; LIST FUNCTIONS FROM COMMON LISP
(define (cl:assoc-adjoin pair lst)
(if (assoc (car pair) lst)
lst
(cons pair lst)))
;; with precedence to first lst
(define cl:assoc-union
(letrec ((onion (lambda (lst1 lst2)
(if (null? lst1)
lst2
(onion (cdr lst1) (cl:assoc-adjoin (car lst1) lst2))))))
(lambda (lst1 lst2)
(cond ((null? lst1) lst2)
((null? lst2) lst1)
(else (onion (reverse lst2) lst1))))))
;;; Some tail-recursive optimizations made by
;;; Colin Walters <walters@cis.ohio-state.edu>
;;; AGJ restored order July 2001.
;;;@ From: hugh@ear.mit.edu (Hugh Secker-Walker)
(define (cl:make-list k . init)
(set! init (if (pair? init) (car init)))
(do ((k (+ -1 k) (+ -1 k))
(result '() (cons init result)))
((negative? k) result)))
;@
(define (cl:copy-list lst) (append lst '()))
;@
(define (cl:adjoin obj lst) (if (member obj lst) lst (cons obj lst)))
;@
(define cl:union
(letrec ((onion
(lambda (lst1 lst2)
(if (null? lst1)
lst2
(onion (cdr lst1) (cl:adjoin (car lst1) lst2))))))
(lambda (lst1 lst2)
(cond ((null? lst1) lst2)
((null? lst2) lst1)
((null? (cdr lst1)) (cl:adjoin (car lst1) lst2))
((null? (cdr lst2)) (cl:adjoin (car lst2) lst1))
((< (length lst2) (length lst1)) (onion (reverse lst2) lst1))
(else (onion (reverse lst1) lst2))))))
;@
(define (cl:intersection lst1 lst2)
(if (null? lst2)
lst2
(let build-intersection ((lst1 lst1)
(result '()))
(cond ((null? lst1)
(if (null? result)
'()
(reverse result)))
((member (car lst1) lst2)
(build-intersection (cdr lst1) (cons (car lst1) result)))
(else (build-intersection (cdr lst1) result))))))
;@
(define (cl:set-difference lst1 lst2)
(if (null? lst2)
lst1
(let build-difference ((lst1 lst1)
(result '()))
(cond ((null? lst1) (reverse result))
((member (car lst1) lst2) (build-difference (cdr lst1) result))
(else (build-difference (cdr lst1) (cons (car lst1) result)))))))
;@
(define (cl:subset? lst1 lst2)
(or (eq? lst1 lst2)
(let loop ((lst1 lst1))
(or (null? lst1)
(and (member (car lst1) lst2)
(loop (cdr lst1)))))))
;@
(define (cl:position obj lst)
(define pos (lambda (n lst)
(cond ((null? lst) #f)
((equal? obj (car lst)) n)
(else (pos (+ 1 n) (cdr lst))))))
(pos 0 lst))
;@
(define (cl:reduce-init pred? init lst)
(if (null? lst)
init
(cl:reduce-init pred? (pred? init (car lst)) (cdr lst))))
;@
(define (cl:reduce pred? lst)
(cond ((null? lst) lst)
((null? (cdr lst)) (car lst))
(else (cl:reduce-init pred? (car lst) (cdr lst)))))
;@
(define (cl:some pred lst . rest)
(cond ((null? rest)
(let mapf ((lst lst))
(and (not (null? lst))
(or (pred (car lst)) (mapf (cdr lst))))))
(else (let mapf ((lst lst) (rest rest))
(and (not (null? lst))
(or (apply pred (car lst) (map car rest))
(mapf (cdr lst) (map cdr rest))))))))
;@
(define (cl:every pred lst . rest)
(cond ((null? rest)
(let mapf ((lst lst))
(or (null? lst)
(and (pred (car lst)) (mapf (cdr lst))))))
(else (let mapf ((lst lst) (rest rest))
(or (null? lst)
(and (apply pred (car lst) (map car rest))
(mapf (cdr lst) (map cdr rest))))))))
;@
(define (cl:notany pred . ls) (not (apply cl:some pred ls)))
;@
(define (cl:notevery pred . ls) (not (apply cl:every pred ls)))
;@
(define (cl:list-of?? predicate . bound)
(define (errout) (apply error 'list-of?? predicate bound))
(case (length bound)
((0)
(lambda (obj)
(and (list? obj)
(cl:every predicate obj))))
((1)
(set! bound (car bound))
(cond ((negative? bound)
(set! bound (- bound))
(lambda (obj)
(and (list? obj)
(<= bound (length obj))
(cl:every predicate obj))))
(else
(lambda (obj)
(and (list? obj)
(<= (length obj) bound)
(cl:every predicate obj))))))
((2)
(let ((low (car bound))
(high (cadr bound)))
(cond ((or (negative? low) (negative? high)) (errout))
((< high low)
(set! high (car bound))
(set! low (cadr bound))))
(lambda (obj)
(and (list? obj)
(<= low (length obj) high)
(cl:every predicate obj)))))
(else (errout))))
;@
(define (cl:find-if pred? lst)
(cond ((null? lst) #f)
((pred? (car lst)) (car lst))
(else (cl:find-if pred? (cdr lst)))))
;@
(define (cl:member-if pred? lst)
(cond ((null? lst) #f)
((pred? (car lst)) lst)
(else (cl:member-if pred? (cdr lst)))))
;@
(define (cl:remove obj lst)
(define head (list '*head*))
(let remove ((lst lst)
(tail head))
(cond ((null? lst))
((eqv? obj (car lst)) (remove (cdr lst) tail))
(else
(set-cdr! tail (list (car lst)))
(remove (cdr lst) (cdr tail)))))
(cdr head))
;@
(define (cl:remove-if pred? lst)
(let remove-if ((lst lst)
(result '()))
(cond ((null? lst) (reverse result))
((pred? (car lst)) (remove-if (cdr lst) result))
(else (remove-if (cdr lst) (cons (car lst) result))))))
;@
(define (cl:remove-if-not pred? lst)
(let remove-if-not ((lst lst)
(result '()))
(cond ((null? lst) (reverse result))
((pred? (car lst)) (remove-if-not (cdr lst) (cons (car lst) result)))
(else (remove-if-not (cdr lst) result)))))
;@
(define cl:nconc
(lambda args
(cond ((null? args) '())
((null? (cdr args)) (car args))
((null? (car args)) (apply cl:nconc (cdr args)))
(else
(set-cdr! (last-pair (car args))
(apply cl:nconc (cdr args)))
(car args)))))
;;;@ From: hugh@ear.mit.edu (Hugh Secker-Walker)
(define (cl:nreverse rev-it)
;;; Reverse order of elements of LIST by mutating cdrs.
(cond ((null? rev-it) rev-it)
((not (list? rev-it))
(error "nreverse: Not a list in arg1" rev-it))
(else (do ((reved '() rev-it)
(rev-cdr (cdr rev-it) (cdr rev-cdr))
(rev-it rev-it rev-cdr))
((begin (set-cdr! rev-it reved) (null? rev-cdr)) rev-it)))))
;@
(define (cl:last lst n)
(cl:nthcdr (- (length lst) n) lst))
;@
(define (cl:butlast lst n)
(cl:butnthcdr (- (length lst) n) lst))
;@
(define (cl:nthcdr n lst)
(if (zero? n) lst (cl:nthcdr (+ -1 n) (cdr lst))))
;@
(define (cl:butnthcdr k lst)
(cond ((negative? k) lst) ;(slib:error "negative argument to butnthcdr" k)
; SIMSYNCH FIFO8 uses negative k.
((or (zero? k) (null? lst)) '())
(else (let ((ans (list (car lst))))
(do ((lst (cdr lst) (cdr lst))
(tail ans (cdr tail))
(k (+ -2 k) (+ -1 k)))
((or (negative? k) (null? lst)) ans)
(set-cdr! tail (list (car lst))))))))
;;;; CONDITIONALS
;@
(define (cl:and? . args)
(cond ((null? args) #t)
((car args) (apply cl:and? (cdr args)))
(else #f)))
;@
(define (cl:or? . args)
(cond ((null? args) #f)
((car args) #t)
(else (apply cl:or? (cdr args)))))
;;;@ Checks to see if a list has any duplicate MEMBERs.
(define (cl:has-duplicates? lst)
(cond ((null? lst) #f)
((member (car lst) (cdr lst)) #t)
(else (cl:has-duplicates? (cdr lst)))))
;;;@ remove duplicates of MEMBERs of a list
(define cl:remove-duplicates
(letrec ((rem-dup (lambda (lst nlst)
(cond ((null? lst) (if (null? nlst) nlst (reverse nlst)))
((member (car lst) nlst) (rem-dup (cdr lst) nlst))
(else (rem-dup (cdr lst) (cons (car lst) nlst)))))))
(lambda (lst)
(rem-dup lst '()))))
;@
(define cl:list*
(letrec ((list*1 (lambda (obj)
(if (null? (cdr obj))
(car obj)
(cons (car obj) (list*1 (cdr obj)))))))
(lambda (obj1 . obj2)
(if (null? obj2)
obj1
(cons obj1 (list*1 obj2))))))
;@
(define (cl:atom? obj)
(not (pair? obj)))
;@
(define (cl:delete obj lst)
(let delete ((lst lst))
(cond ((null? lst) '())
((equal? obj (car lst)) (delete (cdr lst)))
(else
(set-cdr! lst (delete (cdr lst)))
lst))))
;@
(define (cl:delete-if pred lst)
(let delete-if ((lst lst))
(cond ((null? lst) '())
((pred (car lst)) (delete-if (cdr lst)))
(else
(set-cdr! lst (delete-if (cdr lst)))
lst))))
;@
(define (cl:delete-if-not pred lst)
(let delete-if ((lst lst))
(cond ((null? lst) '())
((not (pred (car lst))) (delete-if (cdr lst)))
(else
(set-cdr! lst (delete-if (cdr lst)))
lst))))

17
cabal/share/x86_64-osx-ghc-7.8.4/zepto-0.6.2/stdlib/complete_license Normal file
View File

@@ -0,0 +1,17 @@
zepto - the minimal Scheme Interpreter
Copyright (C) 2015 Veit Heller
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License along
with this program; if not, write to the Free Software Foundation, Inc.,
51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.

9
cabal/share/x86_64-osx-ghc-7.8.4/zepto-0.6.2/stdlib/definitions.scm Normal file
View File

@@ -0,0 +1,9 @@
(define display write)
(define len length)
(define nil '())
(define ok '())
(define fold foldl)
(define reduce fold)
(define ceil ceiling)
(define head car)
(define tail list-tail)

24
cabal/share/x86_64-osx-ghc-7.8.4/zepto-0.6.2/stdlib/delay.scm Normal file
View File

@@ -0,0 +1,24 @@
;; All implementations here are "borrowed" from
;; husk-scheme (github.com/justinethier/husk-scheme).
(define force
(lambda (object)
(object)))
(define-syntax delay
(syntax-rules ()
((delay expression)
(make-promise (lambda () expression)))))
(define make-promise
(lambda (proc)
(let ((result-ready? #f)
(result #f))
(lambda ()
(if result-ready?
result
(let ((x (proc)))
(if result-ready?
result
(begin (set! result x)
(set! result-ready? #t)
result))))))))

76
cabal/share/x86_64-osx-ghc-7.8.4/zepto-0.6.2/stdlib/extra.scm Normal file
View File

@@ -0,0 +1,76 @@
;; All definitions here are "borrowed" from
;; husk (github.com/justinethier/husk-scheme).
(define-syntax cond
(syntax-rules (else =>)
((cond (else result1 result2 ...))
((lambda () result1 result2 ...)))
((cond (test => result))
(let ((temp test))
(if temp (result temp))))
((cond (test => result) clause1 clause2 ...)
(let ((temp test))
(if temp
(result temp)
(cond clause1 clause2 ...))))
((cond (test)) test)
((cond (test) clause1 clause2 ...)
(let ((temp test))
(if temp
temp
(cond clause1 clause2 ...))))
((cond (test result1 result2 ...))
(if test ((lambda () result1 result2 ...))))
((cond (test result1 result2 ...)
clause1 clause2 ...)
(if test
((lambda () result1 result2 ...))
(cond clause1 clause2 ...)))))
(define-syntax case
(syntax-rules (else =>)
((case (key ...)
clauses ...)
(let ((atom-key (key ...)))
(case atom-key clauses ...)))
((case key
(else => result))
(result key))
((case key
(else result1 result2 ...))
(if #t ((lambda () result1 result2 ...))))
((case key
((atoms ...) result1 result2 ...))
(if (memv key '(atoms ...))
((lambda () result1 result2 ...))))
((case key
((atoms ...) => result)
clause clauses ...)
(if (memv key '(atoms ...))
(result key)
(case key clause clauses ...)))
((case key
((atoms ...) result1 result2 ...)
clause clauses ...)
(if (memv key '(atoms ...))
((lambda () result1 result2 ...))
(case key clause clauses ...)))))
(define-syntax when
(syntax-rules ()
((when test result1 result2 ...)
(if test
(begin result1 result2 ...)))))
(define-syntax unless
(syntax-rules ()
((unless test result1 result2 ...)
(if (not test)
(begin result1 result2 ...)))))
(define-syntax letrec*
(syntax-rules ()
((letrec* ((var1 init1) ...) body1 body2 ...)
(let ((var1 #f) ...)
(set! var1 init1)
...
(let () body1 body2 ...)))))

38
cabal/share/x86_64-osx-ghc-7.8.4/zepto-0.6.2/stdlib/io.scm Normal file
View File

@@ -0,0 +1,38 @@
(define (call-with-input-file s p) "open an input file s and apply a function to it, then close the file"
(let ((inport (open-input-file s)))
(if (eq? inport #f)
#f
(let ((res (p inport)))
(close-input-port inport)
res))))
(define (call-with-output-file s p) "open an output file s and apply a function to it, then close the file"
(let ((outport (open-output-file s)))
(if (eq? outport #f)
#f
(let ((res (p outport)))
(close-output-port outport)
res))))
(define (with-input-from-file s p) "open an input file s and run a function while it's open"
(let ((inport (open-input-file s)))
(if (eq? inport #f)
#f
(let ((prev-inport (current-input-port)))
(set-input-port inport)
(let ((res (p)))
(close-input-port inport)
(set-input-port prev-inport)
res)))))
(define (with-output-to-file s p) "open an output file s and run a function while it's open"
(let ((outport (open-output-file s)))
(if (eq? outport #f)
#f
(let ((prev-outport (current-output-port)))
(set-output-port outport)
(let ((res (p)))
(close-output-port outport)
(set-output-port prev-outport)
res)))))

68
cabal/share/x86_64-osx-ghc-7.8.4/zepto-0.6.2/stdlib/let.scm Normal file
View File

@@ -0,0 +1,68 @@
;; All implementations here are "borrowed" from
;; husk-scheme (github.com/justinethier/husk-scheme).
(define-syntax let
(syntax-rules ()
((_ ((x v) ...) e1 e2 ...)
((lambda (x ...) e1 e2 ...) v ...))
((_ name ((x v) ...) e1 e2 ...)
(let*
((f (lambda (name)
(lambda (x ...) e1 e2 ...)))
(ff ((lambda (proc) (f (lambda (x ...) ((proc proc)
x ...))))
(lambda (proc) (f (lambda (x ...) ((proc proc)
x ...)))))))
(ff v ...)))))
(define-syntax let*
(syntax-rules ()
((let* () body1 body2 ...)
(let () body1 body2 ...))
((let* ((name1 val1) (name2 val2) ...)
body1 body2 ...)
(let ((name1 val1))
(let* ((name2 val2) ...)
body1 body2 ...)))))
(define-syntax letrec
(syntax-rules ()
((letrec ((var1 init1) ...) body ...)
(letrec "generate_temp_names"
(var1 ...)
()
((var1 init1) ...)
body ...))
((letrec "generate_temp_names"
()
(temp1 ...)
((var1 init1) ...)
body ...)
(let ((var1 #f) ...)
(let ((temp1 init1) ...)
(set! var1 temp1)
...
body ...)))
((letrec "generate_temp_names"
(x y ...)
(temp ...)
((var1 init1) ...)
body ...)
(letrec "generate_temp_names"
(y ...)
(newtemp temp ...)
((var1 init1) ...)
body ...))))
(define-syntax do
(syntax-rules ()
((_ ((var init . step) ...)
(test expr ...)
command ...)
(let loop ((var init) ...)
(if test
(begin expr ...)
(begin (begin command ...)
(loop
(if (null? (cdr (list var . step)))
(car (list var . step))
(cadr (list var . step))) ...)))))))

2
cabal/share/x86_64-osx-ghc-7.8.4/zepto-0.6.2/stdlib/license.scm Normal file
View File

@@ -0,0 +1,2 @@
(define :license (read-contents "stdlib/license_interactive"))
(define :complete-license (read-contents "stdlib/complete_license"))

5
cabal/share/x86_64-osx-ghc-7.8.4/zepto-0.6.2/stdlib/license_interactive Normal file
View File

@@ -0,0 +1,5 @@
zepto version 0.6.2, Copyright (C) 2015 Veit Heller
zepto comes with ABSOLUTELY NO WARRANTY; for details type `:complete-license'.
This is free software, and you are welcome to redistribute it
under certain conditions; contact the author for details.

9
cabal/share/x86_64-osx-ghc-7.8.4/zepto-0.6.2/stdlib/logical.scm Normal file
View File

@@ -0,0 +1,9 @@
(define (and . lst) "logical and on multiple values" (fold && #t lst))
(define (or . lst) "logical or on multiple values" (fold || #f lst))
(define (not x) "logical not" (if x #f #t))
(define (null? obj) "test for null object"
(if (eqv? obj '())
#t
#f))

124
cabal/share/x86_64-osx-ghc-7.8.4/zepto-0.6.2/stdlib/marsaglia.scm Normal file
View File

@@ -0,0 +1,124 @@
; george marsaglia's random number generators,
; taken from http://programmingpraxis.codepad.org/sf8Z4pJP, edited slightly
; for testing the rngs, a test routine is included (test-rng).
; Testing might take a while, though, because do notation is still very slow.
(define (ipow b e)
(cond ((zero? e) 1)
((even? e) (ipow (* b b) (/ e 2)))
(else (* b (ipow (* b b) (/ (- e 1) 2))))))
(define (logand a b)
(if (or (zero? a) (zero? b)) 0
(+ (* (logand (floor (/ a 2)) (floor (/ b 2))) 2)
(if (or (even? a) (even? b)) 0 1))))
(define (logxor a b)
(cond ((zero? a) b)
((zero? b) a)
(else
(+ (* (logxor (floor (/ a 2)) (floor (/ b 2))) 2)
(if (even? a)
(if (even? b) 0 1)
(if (even? b) 1 0))))))
(define (ash int cnt)
(if (negative? cnt)
(let ((n (ipow 2 (- cnt))))
(if (negative? int)
(+ -1 (quotient (+ 1 int) n))
(quotient int n)))
(* (ipow 2 cnt) int)))
(define mwc #f)
(define shr3 #f)
(define cong #f)
(define fib #f)
(define kiss #f)
(define lfib4 #f)
(define swb #f)
(define uni #f)
(define vni #f)
(define settable #f)
(let ((z 362436069) (w 521288629) (jsr 123456789)
(jcong 380116160) (a 224466889) (b 7584631)
(t (make-vector 256 0)) (x 0) (y 0) (c 0))
(define (mod8 n) (modulo n 256))
(define (mod32 n) (modulo n 4294967296))
(define (ref i) (vector-ref t (mod8 i)))
(set! mwc (lambda ()
(set! z (mod32 (+ (* 36969 (logand z 65535)) (ash z -16))))
(set! w (mod32 (+ (* 18000 (logand w 65535)) (ash w -16))))
(mod32 (+ (ash z 16) w))))
(set! shr3 (lambda ()
(set! jsr (mod32 (logxor jsr (ash jsr 17))))
(set! jsr (mod32 (logxor jsr (ash jsr -13))))
(set! jsr (mod32 (logxor jsr (ash jsr 5)))) jsr))
(set! cong (lambda ()
(set! jcong (mod32 (+ (* 69069 jcong) 1234567))) jcong))
(set! fib (lambda ()
(set! b (mod32 (+ a b))) (set! a (mod32 (- b a))) a))
(set! kiss (lambda ()
(mod32 (+ (logxor (mwc) (cong)) (shr3)))))
(set! lfib4 (lambda ()
(set! c (mod8 (+ c 1)))
(vector-set! t c (mod32 (+ (ref c) (ref (+ c 58))
(ref (+ c 119)) (ref (+ c 178))))) (ref c)))
(set! swb (lambda ()
(set! c (mod8 (+ c 1)))
(let ((bro (if (< x y) 1 0)))
(set! x (mod32 (ref (+ c 34))))
(set! y (mod32 (+ (ref (+ c 19)) bro)))
(vector-set! t c (mod32 (- x y)))
(vector-ref t c))))
(set! uni (lambda ()
(* (kiss) 2.328306e-10)))
(set! vni (lambda ()
(* (- (kiss) 2147483648) 4.6566133e-10)))
(set! settable (lambda (i1 i2 i3 i4 i5 i6)
(set! z i1) (set! w i2) (set! jsr i3) (set! jcong i4)
(set! a i5) (set! b i6) (set! x 0) (set! y 0) (set! c 0)
(do ((i 0 (+ i 1))) ((= i 256))
(vector-set! t i (kiss))))))
(define-syntax rng-assert
(syntax-rules ()
((rng-assert expr result)
(if (not (equal? expr result))
(write
'("failed assertion: "
"expected " result
", returned " expr))
(display "test succesful.")))))
(define (test-rng)
(let ((k 0))
(settable 12345 65435 34221 12345 9983651 95746118)
(display "First test")
(do ((i 0 (+ i 1))) ((= i 1e6) (rng-assert k 1064612766)) (set! k (lfib4)))
(display "Second test")
(do ((i 0 (+ i 1))) ((= i 1e6) (rng-assert k 627749721)) (set! k (swb)))
(display "Third test")
(do ((i 0 (+ i 1))) ((= i 1e6) (rng-assert k 1372460312)) (set! k (kiss)))
(display "Fourth test")
(do ((i 0 (+ i 1))) ((= i 1e6) (rng-assert k 1529210297)) (set! k (cong)))
(display "Fifth test")
(do ((i 0 (+ i 1))) ((= i 1e6) (rng-assert k 2642725982)) (set! k (shr3)))
(display "Sixth test")
(do ((i 0 (+ i 1))) ((= i 1e6) (rng-assert k 904977562)) (set! k (mwc)))
(display "Seventh test")
(do ((i 0 (+ i 1))) ((= i 1e6) (rng-assert k 3519793928)) (set! k (fib)))))
;(test-rng)

27
cabal/share/x86_64-osx-ghc-7.8.4/zepto-0.6.2/stdlib/math.scm Normal file
View File

@@ -0,0 +1,27 @@
(define exact? integer?)
(define (inexact? x) "is inexact number" (and (real? x) (not (integer? x))))
(define (even? n) "is even" (= (remainder n 2) 0))
(define (odd? n) "is odd" (not (= (remainder n 2) 0)))
(define (zero? n) "is zero" (= n 0))
(define (positive? n) "is positive" (> n 0))
(define (negative? n) "is negative" (< n 0))
(define complex? number?)
(define (abs n) "absolute value of number" (if (>= n 0) n (- n)))
(define (exact->inexact n) "make inexact number from exact" (* n 1.0))
(define (<> n1 n2) "not equal" (not (= n1 n2)))
(define (succ x) "next number" (+ x 1))
(define (pred x) "previous number" (- x 1))
(define (gcd a b) "Greatest Common Divisor"
(let ((aa (abs a))
(bb (abs b)))
(if (= bb 0)
aa
(gcd bb (remainder aa bb)))))
(define (lcm a b) "Least Common Multiple"
(if (or (= a 0) (= b 0))
0
(abs (* (quotient a (gcd a b)) b))))

14
cabal/share/x86_64-osx-ghc-7.8.4/zepto-0.6.2/stdlib/module.scm Normal file
View File

@@ -0,0 +1,14 @@
(load "let.scm")
(load "char.scm")
(load "extra.scm")
(load "delay.scm")
(load "io.scm")
(load "logical.scm")
(load "marsaglia.scm")
(load "math.scm")
(load "pairs.scm")
(load "random.scm")
(load "util.scm")
(load "definitions.scm")

28
cabal/share/x86_64-osx-ghc-7.8.4/zepto-0.6.2/stdlib/pairs.scm Normal file
View File

@@ -0,0 +1,28 @@
(define (caar pair) (car (car pair)))
(define (cadr pair) (car (cdr pair)))
(define (cdar pair) (cdr (car pair)))
(define (cddr pair) (cdr (cdr pair)))
(define (caaar pair) (car (car (car pair))))
(define (caadr pair) (car (car (cdr pair))))
(define (cadar pair) (car (cdr (car pair))))
(define (cdaar pair) (cdr (car (car pair))))
(define (caddr pair) (car (cdr (cdr pair))))
(define (cdadr pair) (cdr (car (cdr pair))))
(define (cddar pair) (cdr (cdr (car pair))))
(define (cdddr pair) (cdr (cdr (cdr pair))))
(define (caaaar pair) (car (car (car (car pair)))))
(define (caaadr pair) (car (car (car (cdr pair)))))
(define (caadar pair) (car (car (cdr (car pair)))))
(define (caaddr pair) (car (car (cdr (cdr pair)))))
(define (cadaar pair) (car (cdr (car (car pair)))))
(define (cadadr pair) (car (cdr (car (cdr pair)))))
(define (caddar pair) (car (cdr (cdr (car pair)))))
(define (cadddr pair) (car (cdr (cdr (cdr pair)))))
(define (cdaaar pair) (cdr (car (car (car pair)))))
(define (cdaadr pair) (cdr (car (car (cdr pair)))))
(define (cdadar pair) (cdr (car (cdr (car pair)))))
(define (cdaddr pair) (cdr (car (cdr (cdr pair)))))
(define (cddaar pair) (cdr (cdr (car (car pair)))))
(define (cddadr pair) (cdr (cdr (car (cdr pair)))))
(define (cdddar pair) (cdr (cdr (cdr (car pair)))))
(define (cddddr pair) (cdr (cdr (cdr (cdr pair)))))

16
cabal/share/x86_64-osx-ghc-7.8.4/zepto-0.6.2/stdlib/random.scm Normal file
View File

@@ -0,0 +1,16 @@
;; This code is taken from:
;; http://stackoverflow.com/questions/14674165/scheme-generate-random
;; It is not to be used in cryptography or related fields.
(define random
(let ((a 69069) (c 1) (m (expt 2 32)) (seed 19380110.0))
(lambda new-seed
(if (pair? new-seed)
(begin (set! seed (car new-seed)))
(begin (set! seed (modulo (+ (* seed a) c) m))))
(/ seed m))))
(define (randint . args) "generate a random integer between the given args(the lower range is optional)"
(cond ((= (length args) 1) (randint 0 (car args)))
((= (length args) 2)
(+ (car args) (floor (* (random) (- (cadr args) (car args))))))
(else (write "usage: (randint [lo] hi)"))))

119
cabal/share/x86_64-osx-ghc-7.8.4/zepto-0.6.2/stdlib/sort.scm Normal file
View File

@@ -0,0 +1,119 @@
;;; "sort.scm" Defines: sorted?, merge, merge!, sort, sort!
;;; Author : Richard A. O'Keefe (based on Prolog code by D.H.D.Warren)
;;;
;;; This code is in the public domain.
;;; Updated: 11 June 1991
;;; Modified for scheme library: Aubrey Jaffer 19 Sept. 1991
;;; Updated: 19 June 1995
;;; (sort, sort!, sorted?): Generalized to strings by jaffer: 2003-09-09
;;; (sort, sort!, sorted?): Generalized to arrays by jaffer: 2003-10-04
;;; Modified by Andrew Sorensen for Impromptu 2006-05-10
;;; (cl:sorted? sequence less?)
;;; is true when sequence is a list (x0 x1 ... xm) or a vector #(x0 ... xm)
;;; such that for all 1 <= i <= m,
;;; (not (less? (list-ref list i) (list-ref list (- i 1)))).
;@
(define (cl:sorted? seq less?) "returns whether a sequence is sorted"
(cond ((null? seq) #t)
(else (let loop ((last (car seq)) (next (cdr seq)))
(or (null? next)
(and (not (less? (car next) last))
(loop (car next) (cdr next))))))))
;;; (cl:merge a b less?)
;;; takes two lists a and b such that (sorted? a less?) and (sorted? b less?)
;;; and returns a new list in which the elements of a and b have been stably
;;; interleaved so that (sorted? (merge a b less?) less?).
;;; Note: this does _not_ accept arrays. See below.
;@
(define (cl:merge a b less?) "merges two sorted lists"
(cond ((null? a) b)
((null? b) a)
(else (let loop ((x (car a)) (a (cdr a)) (y (car b)) (b (cdr b)))
;; The loop handles the merging of non-empty lists. It has
;; been written this way to save testing and car/cdring.
(if (less? y x)
(if (null? b)
(cons y (cons x a))
(cons y (loop x a (car b) (cdr b))))
;; x <= y
(if (null? a)
(cons x (cons y b))
(cons x (loop (car a) (cdr a) y b))))))))
;;; (cl:merge! a b less?)
;;; takes two sorted lists a and b and smashes their cdr fields to form a
;;; single sorted list including the elements of both.
;;; Note: this does _not_ accept arrays.
;@
(define (cl:merge! a b less?) "merges two sorted lists"
(define (loop r a b)
(if (less? (car b) (car a))
(begin (set-cdr! r b)
(if (null? (cdr b))
(set-cdr! b a)
(loop b a (cdr b))))
;; (car a) <= (car b)
(begin (set-cdr! r a)
(if (null? (cdr a))
(set-cdr! a b)
(loop a (cdr a) b)))))
(cond ((null? a) b)
((null? b) a)
((less? (car b) (car a))
(if (null? (cdr b))
(set-cdr! b a)
(loop b a (cdr b)))
b)
(else (if (null? (cdr a))
(set-cdr! a b)
(loop a (cdr a) b))
a)))
;;; (cl:sort! sequence less?)
;;; sorts the list, array, or string sequence destructively. It uses
;;; a version of merge-sort invented, to the best of my knowledge, by
;;; David H. D. Warren, and first used in the DEC-10 Prolog system.
;;; R. A. O'Keefe adapted it to work destructively in Scheme.
;@
(define (cl:sort! seq less?) "sorts a sequence destructively; merge-sort"
(define (step n)
(cond ((> n 2)
(let* ((j (quotient n 2))
(a (step j))
(k (- n j))
(b (step k)))
(cl:merge! a b less?)))
((= n 2)
(let ((x (car seq))
(y (cadr seq))
(p seq))
(set! seq (cddr seq))
(cond ((less? y x)
(set-car! p y)
(set-car! (cdr p) x)))
(set-cdr! (cdr p) '())
p))
((= n 1)
(let ((p seq))
(set! seq (cdr seq))
(set-cdr! p '())
p))
(else '())))
(step (length seq)))
;;; (cl:sort sequence less?)
;;; sorts a array, string, or list non-destructively. It does this
;;; by sorting a copy of the sequence. My understanding is that the
;;; Standard says that the result of append is always "newly
;;; allocated" except for sharing structure with "the last argument",
;;; so (append x '()) ought to be a standard way of copying a list x.
;@
(define (cl:sort seq less?) "sorts a sequence non-destructively; merge-sort"
(cond ((vector? seq)
(list->vector (cl:sort! (vector->list seq) less?)))
((string? seq)
(list->string (cl:sort! (string->list seq) less?)))
(else (cl:sort! (append seq '()) less?))))

163
cabal/share/x86_64-osx-ghc-7.8.4/zepto-0.6.2/stdlib/util.scm Normal file
View File

@@ -0,0 +1,163 @@
(define (list . objs) "creates a list from objects"
objs)
(define (id obj) "returns an object"
obj)
(define (flip func) "flips two arguments for a function"
(lambda (arg1 arg2)
(func arg2 arg1)))
(define (list-tail l k) "get tail of a list"
(if (zero? k)
l
(list-tail (cdr l) (- k 1))))
(define (list-ref l k) "get reference to list element at certain point"
(car (list-tail l k)))
(define (append i a) "append something to a list"
(foldr (lambda (ax ix) (cons ax ix)) a i))
(define (curry func arg1) "curry a function"
(lambda (arg)
(func arg1 arg)))
(define (compose f g) "compose two functions"
(lambda (arg)
(f (apply g arg))))
(define (foldr func end l) "fold right"
(if (null? l)
end
(func (car l) (foldr func end (cdr l)))))
(define (foldl func accum l) "fold left"
(if (null? l)
accum
(foldl func (func accum (car l)) (cdr l))))
(define (generate func init pred)
(if (pred init)
(cons init '())
(cons init (unfold func (func init) pred))))
(define (sum . l) "sum of values"
(fold + 0 l))
(define (product . l) "product of values"
(fold * 1 l))
(define (max first . l) "maximum of values"
(fold (lambda (old new)
(if (> old new) old new))
first
l))
(define (min first . l) "minimum of values"
(fold (lambda (old new)
(if (< old new) old new))
first
l))
(define (length l) "length of list"
(fold (lambda (x y)
(+ x 1))
0
l))
(define (reverse l) "reverse list"
(fold (flip cons) '() l))
(define (my-mem-helper obj lst cmp-proc)
(cond
((null? lst) #f)
((cmp-proc obj (car lst)) lst)
(else (my-mem-helper obj (cdr lst) cmp-proc))))
(define (memq obj lst) (my-mem-helper obj lst eq?))
(define (memv obj lst) (my-mem-helper obj lst eqv?))
(define (member obj lst) (my-mem-helper obj lst equal?))
(define (mem-helper pred op) (lambda (acc next) (if (and (not acc) (pred (op next))) next acc)))
(define (assq obj alist) (fold (mem-helper (curry eq? obj) car) #f alist))
(define (assv obj alist) (fold (mem-helper (curry eqv? obj) car) #f alist))
(define (assoc obj alist) (fold (mem-helper (curry equal? obj) car) #f alist))
(define (map func l) "map function to list"
(foldr (lambda (x y)
(cons (func x) y))
'()
l))
(define (foreach func l) "apply function to each element on the list"
(foldl (lambda (x y)
(cons (func x) y))
'()
l))
(define (filter pred l) "filter list through preidcate"
(foldr (lambda (x y)
(if (pred x)
(cons x y)
y))
'()
l))
(define (any? pred lst) "does anything in the list satisfy the predicate?"
(let any* ((l (map pred lst)))
(cond
((null? l) #f)
((car l) #t)
(else
(any* (cdr l))))))
(define (every? pred lst) "do all values in the list satisfy the predicate?"
(let every* ((l (map pred lst)))
(cond
((null? l) #t)
((car l)
(every* (cdr l)))
(else
#f))))
(define all? every?)
(define (case x . cs)
if (== cs ())
("No Case Found")
(if (== x (caar cs))
(cadar cs)
(unpack case (join (list x) (cdr cs)))))
(define (iota n) "makes a list from numbers from 0 to n"
(let ((acc '()))
(do ((i 0 (+ i 1))) ((= i n)) (set! acc (append acc (list i)))) acc))
(define (unzip1-with-cdr . lists)
(unzip1-with-cdr-iterative lists '() '()))
(define (unzip1-with-cdr-iterative lists cars cdrs)
(if (null? lists)
(cons cars cdrs)
(let ((car1 (caar lists))
(cdr1 (cdar lists)))
(unzip1-with-cdr-iterative
(cdr lists)
(append cars (list car1))
(append cdrs (list cdr1))))))
(define (for-each proc . lists) "applies a function to a bunch of arguments"
(if (null? lists)
(apply proc)
(if (null? (car lists))
#t
(let* ((unz (apply unzip1-with-cdr lists))
(cars (car unz))
(cdrs (cdr unz)))
(apply proc cars) (apply map (cons proc cdrs))))))