summaryloggraphiclog1graphiclog2commitcommitdifftreerefseditfork
rawpatchinlineside by side (initial)
rawpatchinlineside by side (initial)
| author | Li Ian-Xue <[email protected]> | |
| Mon, 1 Oct 2012 17:45:12 +0000 (2 01:45 +0800) | ||
| committer | Li Ian-Xue <[email protected]> | |
| Mon, 1 Oct 2012 17:45:12 +0000 (2 01:45 +0800) |
| fannkuch-redux.scm | [new file with mode: 0644] | patchblob |
| twenty.scm | [new file with mode: 0644] | patchblob |
| with-barrier.scm | [new file with mode: 0644] | patchblob |
diff --git a/fannkuch-redux.scm b/fannkuch-redux.scm
--- /dev/null
+++ b/fannkuch-redux.scm
@@ -0,0 +1,51 @@
+(define (rotate ls)
+ (if (null? ls)
+ ls
+ (append (cdr ls) (list (car ls)))))
+
+(define (permutations ls)
+ (let ((len (length ls)))
+ (if (= 1 len)
+ (list ls)
+ (let r ((result '()) (ls1 ls) (rotate-times len))
+ (if (= 0 rotate-times)
+ result
+ (r (append result
+ (map (lambda (x) (cons (car ls1) x))
+ (permutations (cdr ls1))))
+ (rotate ls1) (- rotate-times 1)))))))
+
+(define (permutation2 ls) ;generator style
+ (let ((len (length ls)))
+ (if (= 1 len)
+ (list ls)
+ (let r ((result '()) (ls1 ls) (rotate-times len))
+ (if (= 0 rotate-times)
+ result
+ (r (append result
+ (map (lambda (x) (cons (car ls1) x))
+ (permutations (cdr ls1))))
+ (rotate ls1) (- rotate-times 1)))))))
+
+(define (m1 v k)
+ (lambda (x) (k (cons v x))))
+
+
+(define (reverse-by-first-elem ls)
+ (let ((n (car ls)))
+ (append (reverse (list-head ls n))
+ (list-tail ls n))))
+
+(define (max-flips ls)
+ (let r ((times 0) (nls ls))
+ (let ((e1 (car nls)))
+ (if (= 1 e1)
+ times
+ (r (+ 1 times) (reverse-by-first-elem nls))))))
+
+;; (define q '(1 2 3 4 5 6 7 8 9 10 11 12))
+
+;; (display (apply max (map max-flips (permutations ))))
+;; (newline)
+
+(define q (make-bytevector 7))
diff --git a/twenty.scm b/twenty.scm
--- /dev/null
+++ b/twenty.scm
@@ -0,0 +1,338 @@
+;; TWENTY CHALLENGES FOR GREAT JUSTICE\r
+;; ===================================\r
+\r
+;; by quad\r
+\r
+\r
+\r
+\r
+;; CHALLENGE 1\r
+\r
+;; Define a macro THUNK which will wrap the body of the macro inside a lambda. That\r
+;; is, define\r
+\r
+;; (THUNK\r
+;; <body>)\r
+\r
+;; so that we get\r
+\r
+;; (lambda () <body>)\r
+\r
+\r
+;; CHALLENGE 2\r
+\r
+; Quadrescence:\r
+; First, tell me why this can't be a function.\r
+; Then implement it as a macro. --> A procedure called\r
+; SET-IF! such that (set-if! pred sym val) sets the value of SYM to VAL\r
+; only if PRED is true. Otherwise, it does nothing.\r
+; (or if you want, otherwise, it just gives back NIL)\r
+\r
+(define-syntax set-if!\r
+ (syntax-rules ()\r
+ ((_ pred sym val) (if pred\r
+ (set! sym val)))))\r
+\r
+(macroexpand '(set-if! #f a 5))\r
+\r
+(void)\r
+\r
+;; CHALLENGE 3\r
+\r
+; Quadrescence | qu1j0t3, EXERCISE: Write a version of LETREC which\r
+; allows one to use DEFINE syntax.\r
+; I think that syntax is more consistent with\r
+; general scheme syntax anyway. It's a little baroque\r
+; and definitely not "minimal" but neither is being able\r
+; to do (define (f x) ...)\r
+; when (define f (lambda (x) ...)) works fine\r
+; Example:\r
+; (define (example x)\r
+; (with-definitions\r
+; ((define (is-even? x) (zero? (remainder x 2)))\r
+; (define rofl "rolling on the floor laughing"))\r
+; (if (is-even? x)\r
+; (display rofl)\r
+; (display ":("))))\r
+\r
+(define-syntax with-definitions\r
+ (syntax-rules () ())\r
+\r
+(syntax->datum (syntax (foo bar baz)))\r
+\r
+\r
+;; CHALLENGE 4\r
+\r
+; Qworkescence | Similar in spirit to the counting change problem,\r
+; write a function to compute the "partitions of an integer".\r
+; A partition of N is some sum of smaller numbers that add to N.\r
+; So the partitions of 4 are (4) (3 1) (2 2) (2 1 1) (1 1 1 1)\r
+\r
+\r
+;; CHALLENGE 5\r
+\r
+; Quadrescence | CHALLENGE: replicate SML's reference type in scheme\r
+; | (define a (ref 9))\r
+; | (set-ref! a 8)\r
+; | (val a)\r
+; | ==> 8\r
+; | you can use "deref" instead of "val"\r
+\r
+\r
+;; CHALLENGE 6\r
+\r
+; Quadrescence | CHALLENGE: write bogosort\r
+\r
+\r
+;; CHALLENGE 7\r
+\r
+; Quadrescence | replicate the behavior of ye olde lisp's SETQ,\r
+; which is like SET! but allows several pairs of idents and vals\r
+; e.g., (setq x 1 y 2 z 3)\r
+; x is set to 1, y to 2, z to 3\r
+\r
+\r
+;; CHALLENGE 8\r
+\r
+; @Quadrescence | CHALLENGE: Make a macro (define* (f args) body)\r
+; which defines f to be memoized: when you call f with\r
+; arguments x, it'll save the value of the result\r
+; so next time around, it just looks up the result.\r
+; Extra credit: Do it without polluting the namespace\r
+; (except w/ the function name of course)\r
+\r
+\r
+;; CHALLENGE 9\r
+\r
+; In challenge #8, you wrote a memoizing\r
+; DEFINE macro called DEFINE*. However,\r
+; this can be awkward and even inefficient\r
+; when we have a COND or CASE. Consider:\r
+\r
+; (define* (fib n)\r
+; (cond ((= n 0) 0)\r
+; ((= n 1) 1)\r
+; (else (+ (fib (- n 1))\r
+; (fib (- n 2))))))\r
+\r
+; Each time we compute a yet-uncomputed\r
+; fibonacci, we have to check if it's 0\r
+; first, then 1, then we can procede to\r
+; compute.\r
+\r
+; In this challenge, we want to be allowed\r
+; to define constant cases which add to\r
+; the hash table immediately. Let's call\r
+; this definition procedure DEF.\r
+\r
+; Example:\r
+\r
+; (def fib\r
+; (0) => 0\r
+; (1) => 1\r
+; (n) => (+ (fib (- n 1))\r
+; (fib (- n 2))))\r
+\r
+; This will create a function FIB which will\r
+; have zero and one memoized, and allow for\r
+; the general case. When we do call the general\r
+; case for an unmemoized function, we no longer\r
+; have to crawl the COND, because there is none.\r
+; So we save comparisons each time it's called.\r
+\r
+; For multi-argument functions, it would be illegal to have (4 b c) => ...\r
+; for example.\r
+; you can safely assume the last case will be the variable case\r
+\r
+\r
+;; CHALLENGE 10\r
+\r
+; @Quadrescence | qu1j0t3: this one isn't tough, but it's an important\r
+; demonstration. Write a macro "with-degrees"\r
+; which causes all trig functions (sin cos tan) to use degrees\r
+; and not radians. Therefore if there is a\r
+; (sin x), it should be changed to (sin (* pi (/ 180) x)),\r
+; where pi=3.14159265358979\r
+; (with-degrees (+ (sin 30) (sin 90))) should give 1.5\r
+\r
+\r
+;; CHALLENGE 11\r
+\r
+; Quadrescence | as an exercise, you should implement a C-style FOR loop:\r
+; (for ((<var> <init>) <condition> <post-loop-thing>) <body>)\r
+; without using DO\r
+; and <var>'s scope should be limited to FOR\r
+; example: (for ((i 0)\r
+; (< i 10)\r
+; (set! i (+ 1 i)))\r
+; (display i)\r
+; (newline))\r
+; which would print 0 thru 9\r
+; UNLIKE C, i's scope is limited\r
+; Quadrescence | Now extend FOR so you can do (for (<VAR> <LST>) ...)\r
+; and it will iterate over the list\r
+; (this is equivalent to CL's DOLIST macro)\r
+\r
+\r
+;; CHALLENGE 12\r
+\r
+// Quadrescence | write a program which takes a sentence (you can assume no punctuation)\r
+// and mixes the middle letters of the words randomly, and writes it to stdout\r
+// based on that classic thing where you can read text even if the middle letters\r
+// are scrambled, but the first and last remain the same\r
+\r
+\r
+;; CHALLENGE 13\r
+\r
+; Quad:\r
+; I think you should create the macro you suggested. In Common Lisp,\r
+; this macro is DESTRUCTURING-BIND. One way it works is like this (schemified):\r
+; (define *list* '(1 2 3))\r
+; (destructuring-bind (a b c) *list*\r
+; (+ a b c))\r
+; ===> 6\r
+\r
+\r
+;; CHALLENGE 14\r
+\r
+; Qworkescence | But the last time I wrote an infix parser was for an\r
+; arithmetic expression parser which recognizes\r
+; associativity of operands and the natural solution is\r
+; from our friend Dijkstra and his beautifully simple\r
+; Shunting Yard algorithm\r
+; Qworkescence | Exercise: Read about & implement shunting yard\r
+; Qworkescence | (in Scheme)\r
+\r
+\r
+;; CHALLENGE 15\r
+\r
+; Qworkescence | qu1j0t3, easy exercise: write the following functions\r
+; in Scheme equivalent to their Common Lisp counterparts:\r
+; (CONSTANTLY x) which returns a function which takes\r
+; any number of args but always returns x\r
+\r
+; and (COMPLEMENT fn) which takes a boolean function fn\r
+; and returns the logical inverse (NOT) of it\r
+\r
+; Qworkescence | CHALLENGE: If COMPLEMENT is the analog of the boolean\r
+; function NOT, then write two functions (CONJUNCTION f g)\r
+; which returns a function which takes an argument\r
+; and checks if both f and g are satisfied.\r
+\r
+; And write (DISJUNCTION f g) which returns a function\r
+; which takes an argument and checks if either f or g are\r
+; satisfied\r
+\r
+; (clearly CONJUNCTION is the analog of boolean AND,\r
+; and DISJUNCTION is the analog of boolean OR)\r
+; if you have CONJUNCTION, then you can do stuff like...\r
+; (define (divisible-by n)\r
+; (lambda (x) (zero? (remainder x n))))\r
+; (filter (conjunction (disjunction (divisible-by 3)\r
+; (divisible-by 5))\r
+; (complement (divisible-by 15)))\r
+; some-list)\r
+; filter those elements divisible by 3 or 5 and not 15\r
+\r
+\r
+;; CHALLENGE 16\r
+\r
+; Quadrescence | write (transpose matrix) which transposes.\r
+; Quadrescence | If you don't know what transposition is,\r
+; every row becomes a column, vice versa\r
+\r
+\r
+;; CHALLENGE 17\r
+\r
+; qu1j0t3 | Quadrescence: (diagonal? might be a nice scheme challenge..\r
+;Quadrescence | first make a function called "square-matrix?" to see\r
+; if it's even a matrix\r
+; then write diagonal? to determine if the matrix is a diagonal\r
+; matrix\r
+\r
+\r
+;; CHALLENGE 18\r
+\r
+;15:41:53 Quadrescence | FurnaceBoy: Oh, another "small" Scheme challenge:\r
+; Given a list of functions L = (f1 f2 ... fn) and a value x, write a\r
+; function (appList F x) := ((f1 x) (f2 x) ... (fn x)) ¦\r
+; e.g., if L = (sin cos tan), then (appList L 3.14) gives\r
+; (0.00159265291648683 -0.99999873172754 -0.00159265493640722)\r
+\r
+\r
+;; CHALLENGE 19\r
+\r
+Furthermore, make (appList* L) return a function such that ((appList* L) x) is\r
+equivalent to appList in Challenge 18\r
+\r
+\r
+;; CHALLENGE 20\r
+\r
+Write a macro LOCALS which acts sort of like LET, but allows uninitialized values\r
+(you may initialize them to #f). For example\r
+\r
+(locals (a b (c 1) d)\r
+ (set! a 5)\r
+ (+ a c))\r
+\r
+returns\r
+\r
+ 6\r
+\r
+\r
+;; CHALLENGE 21\r
+\r
+Write define-curried which defines a curried function. That is,\r
+(define-curried-function (clog b x) (/ (log x) (log b))), which sets clog to\r
+ (lambda (b)\r
+ (lambda (x)\r
+ (log b x)))\r
+\r
+\r
+;; CHALLENGE 22\r
+\r
+Write (@ f x y z ...) which applies f to x, then the result to y, etc. For\r
+example, (@ clog 2 5) ==> ((clog 2) 5)\r
+\r
+\r
+;; CHALLENGE 23\r
+\r
+The tangent of a number tan(x) is defined as sin(x)/cos(x). We can\r
+compute tangent by using the definition, or we can make use of the\r
+so called "addition formula". The addition formula for tangent is\r
+\r
+ tan(a) + tan(b)\r
+ tan(a + b) = ----------------- .\r
+ 1 - tan(a)*tan(b)\r
+\r
+If we wish to compute tan(x), then we can compute tan(x/2 + x/2):\r
+\r
+ x x tan(x/2) + tan(x/2) 2*tan(x/2)\r
+ tan(- + -) = --------------------- = ---------------- .\r
+ 2 2 1 - tan(x/2)*tan(x/2) 1 - (tan(x/2))^2\r
+\r
+We also know something about tangent when the argument is small:\r
+\r
+ tan(x) ~= x when x is very close to 0.\r
+\r
+The exercise has two parts:\r
+\r
+ (1) Write a recursive function TANGENT using the methods above\r
+ to compute the tangent of a number. It is not necessary to\r
+ handle undefined cases (odd multiples of pi/2).\r
+\r
+ (2) Write an iterative version TANGENT-ITER of (1) which avoids\r
+ tree recursion (uses named-LET or tail-recursive procedures).\r
+\r
+\r
+TEST CASES: Your values need not match these precisely (due to\r
+floating point error and implementation specifics).\r
+\r
+> (tangent-iter 0)\r
+0\r
+> (tangent-iter 1.0)\r
+1.5574066357129577\r
+> (tangent-iter 2.0)\r
+-2.1850435345286616\r
+> (tangent-iter (/ 3.14159 4))\r
+0.9999983651876447\r
diff --git a/with-barrier.scm b/with-barrier.scm
--- /dev/null
+++ b/with-barrier.scm
@@ -0,0 +1,23 @@
+(define a)
+
+;; entering a barrier
+(with-continuation-barrier
+ (lambda ()
+ (call/cc
+ (lambda (k)
+ (set! a k)
+ 1
+ ))))
+
+(a) ;exception!
+
+
+;;;; leaving a barrier
+(call/cc
+ (lambda (k)
+ (set! a k)
+ 1
+ ))
+
+(with-continuation-barrier
+ (lambda () (a))) ;exception!