Generalised composition


    ## Generalised composition [scheme]
(define (compose . fns)
  (define (make-chain fn chain)
    (lambda args
      (call-with-values (lambda () (apply fn args)) chain)))
  (fold make-chain values fns))

    Most people have worked with a simple kind of function composition: one that is essentially (lambda (f g) (lambda (x) (f (g x)))). SRFI 41 (http://srfi.schemers.org/srfi-41/srfi-41.html) describes a more general composition, that takes an arbitrary number of functions, and that allows each function to return multiple values. Here's my version of the same idea, but using "fold" from SRFI 1 (http://srfi.schemers.org/srfi-1/srfi-1.html), which I think is much cleaner from a functional programming point of view. Feel free to refactor this to make it even more functional. :-)
    2009-04-22T04:24:55+00:00
    836
    Lisp
    generalised-compose
    1
    Generalised composition
    
    2009-04-22T05:07:18+00:00
    611
    
      611
      http://chris.jester-young.name/
      Chris Jester-Young
      4.3333
      29


    (define (remove-subnodes n L)
  (cond ((null? L) `())
	((= n (car L)) L)
	(else (remove-subnodes n (cdr L)))))

(define (subnode-of? n1 n2)
  (< n1 n2))

(define (equal-nodes? n1 n2)
  (= n1 n2))

; Take a list of numbers and build a list 
; where subnodes are 1 less than thier parent
; nodes on the same level are equal. 
; 
; (build-list `(0 1 1 2 2 1 1 2 1 0)
; => (0 (1 1 (2 2) 1 1 (2) 1) 0)
;
; (build-list `(0 1 2 3 4 5 1 0))
; => (0 (1 (2 (3 (4 (5)))) 1) 0)
;
; (build-list `(1 2 1 2))
; => (1 (2) 1 (2))
;
(define (build-list L)
  (define (helper n L)
    (cond ((null? L) `())
	  ((subnode-of? n (car L))
           (cons (cons (car L) 
		       (helper (car L) (cdr L)))
		 (helper n (remove-subnoes n (cdr L)))))
	  ((equal-nodes? n (car L))
	   (cons (car L)
		 (helper (car L) (cdr L))))
	  (else `())))
  (cons (car L) (helper (car L) (cdr L))))

    This is written in a dialect of lisp: scheme.  The first 3 functions are helper functions, the main function is the last function. Basically it creates a list of varying depths by parsing a list of numbers.  Each number represents the depth that the element in the new list should have.  I'm hoping someone can come up with a more straight forward way to accomplish what the below code does.


    2008-09-09T05:35:15+00:00
    486
    Lisp
    super-simple-parser-in-scheme
    0
    Super Simple Parser in Scheme
    
    2008-09-09T15:53:24+00:00
    1000
    
      1000
      http://rooster.myopenid.com
      rooster.myopenid.com
      0.0
      0


    ## Main program [scheme]
#!/usr/bin/guile \
-e main -s
!#
(use-modules
  (srfi srfi-1)
  (srfi srfi-4)
  (ice-9 getopt-long))

(define (u8+ . args)
  (logand (apply + args) 255))

(define (make-sbox key rounds)
  (let 
      ((sbox (apply u8vector (iota 256)))
       (s2 (apply vector (take (apply circular-list
         (map char->integer (string->list key))) 256)))
       (j 0))
    (do
        ((k rounds (- k 1)))
        ((< k 1))
      (for-each
        (lambda (i)
          (let
              ((temp (u8vector-ref sbox i)))
            (set! j (u8+ j temp (vector-ref s2 i)))
            (u8vector-set! sbox i (u8vector-ref sbox j))
            (u8vector-set! sbox j temp)))
        (iota 256)))
    (vector-fill! s2 0)
    sbox))

(define (crypt-loop sbox)
  (let loop
      ((i 1)
       (j 0))
    (let
        ((ch (read-char)))
      (if (not (eof-object? ch))
        (let*
            ((temp (u8vector-ref sbox i))
             (newj (u8+ j temp)))
          (u8vector-set! sbox i (u8vector-ref sbox newj))
          (u8vector-set! sbox newj temp)
          (let
              ((val (u8vector-ref sbox (u8+ (u8vector-ref sbox i) temp))))
            (write-char (integer->char (logxor (char->integer ch) val)))
            (loop (u8+ i 1) newj)))))))

(define (do-crypt key iv rounds)
  (crypt-loop (make-sbox (string-append key iv) rounds)))

(define (encrypt key rounds)
  (let
      ((iv (call-with-input-file "/dev/urandom"
        (lambda (port)
          (setvbuf port _IOFBF 10)
          (string-tabulate (lambda (i) (read-char port)) 10)))))
    (display iv)
    (do-crypt key iv rounds)))

(define (decrypt key rounds)
  (let
      ((iv (string-tabulate (lambda (i) (read-char)) 10)))
    (do-crypt key iv rounds)))

(define (main args)
  (let*
      ((options (getopt-long args
        `((key (single-char #\k) (required? #t) (value #t))
          (rounds (single-char #\n) (value #t) (predicate ,string->number))
          (decrypt (single-char #\d)))))
       (key (option-ref options 'key #f))
       (rounds (string->number (option-ref options 'rounds "20")))
       (decrypt? (option-ref options 'decrypt #f)))
    ((if decrypt? decrypt encrypt) key rounds)))

    Apparently the last Scheme posting was half a year ago, so let's have more!

Quick executive summary of the code: CipherSaber (http://ciphersaber.gurus.org/) uses Arcfour (http://www.mozilla.org/projects/security/pki/nss/draft-kaukonen-cipher-arcfour-03.txt) for encryption, and the first 10 bytes of the encrypted file is the IV, which is appended to the user-specified key when keying the S-box.

I'm currently learning Scheme, and figure I could get some feedback on how to write more "idiomatic" Scheme programs...there are some things in my code at the moment that I'm not very happy with, like the "do" loop...I'm sure there's an analogue to Ruby "each" function that I'm yet to learn about. :-) I also don't see an easy way to avoid set!-ting j in the S-box setup loop...unlike in the main crypt loop.

There are also some Guile-isms in the code, like using logand/logxor without importing SRFI 60, getopt-long, and setvbuf. And Unixisms, like reading /dev/urandom. Apart from those, the code should be fairly "standard" R5RS.
    2008-06-22T05:39:36+00:00
    336
    Lisp
    ciphersaber
    1
    CipherSaber
    
    2008-06-25T16:26:26+00:00
    611
    
      611
      http://chris.jester-young.name/
      Chris Jester-Young
      4.3333
      29


    ;; Turns a flat-list into a list of n-sized lists
;; Examples:
;;   (group-by '(1 2 3 4) 2) => ((1 2) (3 4))
;;   (group-by '(a b c d) 3) => ((a b c) (d))
;;   (group-by '(a b c d) 1) => ((a) (b) (c) (d))
;;   (group-by '(a b c d) 4) => ((a b c d))
;;   (group-by '(a b c d e f 1 2 3 4 5 6) 7) => (a b c d e f 1) (2 3 4 5 6))

(define (group-by x n)
  (let loop ((x x) (grouped '()) (current '()) (i 0))
    (if (null? x)
	(reverse (cons (reverse current) grouped))
	(if (= i n)
	    (loop x (cons (reverse current) grouped) '() 0)
	    (loop (cdr x) grouped (cons (car x) current) (+ i 1))))))
    Tested on MzScheme
    2007-12-21T19:55:33+00:00
    193
    Lisp
    group-by
    5
    Group-by
    
    2008-06-29T09:33:18+00:00
    424
    
      424
      http://omouse.vox.com
      omouse.vox.com
      0.0
      0


      ; 5*O(n)
  (defun next-lex (a)
    (let* ((r (reverse a))
           (pivot (first-down r)))
      (multiple-value-bind
        (less-pivot greater-pivot before-pivot) (partition-upto pivot r)
        (nreverse (append (cdr greater-pivot) (list pivot) less-pivot
              (list (car greater-pivot)) before-pivot)))))

  ; O(n)
  (defun first-down (a)
    (if (numberp (cadr a))
      (if (> (car a) (cadr a))
        (cadr a)
        (first-down (cdr a)))
      nil))

  ; O(n)
  (defun partition-upto (pivot a)
    (labels ((partition-sub (pivot a less more)
      (cond
        ((eql (car a) pivot)
         (values less (nreverse more) (cdr a)))
        ((> (car a) pivot)
         (partition-sub pivot (cdr a) less (cons (car a) more)))
        ((< (car a) pivot)
         (partition-sub pivot (cdr a) (cons (car a) less) more)))))
      (partition-sub pivot a () ())))

;; > (next-lex '(1 3 5))
;; (1 5 3)
    Given a list of numbers, generate their alphabetically next permutation.

Can this be shorter?
    2007-10-04T00:19:44+00:00
    55
    Lisp
    lexicographically-next-permutation
    12
    Lexicographically next permutation
    
    2009-12-20T18:51:47+00:00
    140
    
      140
      http://akkartik.livejournal.com
      Kartik Agaram
      0.0
      4
      http://akkartik.name


    (defun transpose (m)
       (cond
        ((null (car m)) nil)
        (T (cons (mapcar 'car m) (transpose (mapcar 'cdr m))))
       ))

(transpose '((1 2 3) (4 5 6) (7 8 9)))
    simpler? shorter?
    2007-10-03T11:12:52+00:00
    53
    Lisp
    matrix-transpose
    5
    matrix transpose
    
    2008-05-23T21:58:33+00:00
    64
    
      64
      http://mrsheep.myopenid.com/
      mrsheep
      0.0
      0


    
(defun header-encode (string)
  (if (find-if (lambda (c) (> (char-code c) 127)) string)
      (format nil "~{ =?utf-8?B?~A?=~%~}"
	      (cl-ppcre:split #\Newline
			      (cl-base64:usb8-array-to-base64-string
			       (portable-string-to-octets string)
			       :columns 40)))
      (format nil " ~A~%" string)))

(defun mail-headers (to from subject mime-type)
  (format nil "To: ~A
From: ~A
Subject:~AContent-Type: ~A;charset=utf-8
" to from (header-encode subject) mime-type))

(defun better-mail-headers (to from subject mime-type)
  (format nil "To: ~A
From: ~A
Subject: ~A
Content-Type: ~A;charset=utf-8
" to from (header-encode subject) mime-type))

    I would like to use header-encode without needing to squeeze out the whitespace, as in better-mail-headers
    2007-10-02T11:37:11+00:00
    45
    Lisp
    folding-of-non-ascii-long-header-fields-rfc2822-section-2-2-3
    2
    folding of non-ascii long header fields (rfc2822 section 2.2.3)
    
    2007-10-02T11:37:11+00:00
    121
    
      121
      http://luser.myopenid.com/
      luser.myopenid.com/
      0.0
      1