Added cabal and vim dir
This commit is contained in:
hellerve
@@ -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.10.1/zepto-0.6.3/stdlib/comlist.scm
Normal file
316
cabal/share/x86_64-osx-ghc-7.10.1/zepto-0.6.3/stdlib/comlist.scm
Normal 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))))
|
||||
@@ -0,0 +1,8 @@
|
||||
(define len length)
|
||||
(define nil '())
|
||||
(define ok '())
|
||||
(define fold foldl)
|
||||
(define reduce fold)
|
||||
(define ceil ceiling)
|
||||
(define head car)
|
||||
(define tail list-tail)
|
||||
@@ -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))))))))
|
||||
@@ -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.10.1/zepto-0.6.3/stdlib/io.scm
Normal file
38
cabal/share/x86_64-osx-ghc-7.10.1/zepto-0.6.3/stdlib/io.scm
Normal 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.10.1/zepto-0.6.3/stdlib/let.scm
Normal file
68
cabal/share/x86_64-osx-ghc-7.10.1/zepto-0.6.3/stdlib/let.scm
Normal 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))) ...)))))))
|
||||
@@ -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))
|
||||
@@ -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)
|
||||
@@ -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))))
|
||||
@@ -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")
|
||||
@@ -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)))))
|
||||
@@ -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.10.1/zepto-0.6.3/stdlib/sort.scm
Normal file
119
cabal/share/x86_64-osx-ghc-7.10.1/zepto-0.6.3/stdlib/sort.scm
Normal 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.10.1/zepto-0.6.3/stdlib/util.scm
Normal file
163
cabal/share/x86_64-osx-ghc-7.10.1/zepto-0.6.3/stdlib/util.scm
Normal 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))))))
|
||||
Reference in New Issue
Block a user