ozten

CGI

-- ghc --make -o CgiPlay.cgi CgiPlay.hs 
import Network.CGI

cgiMain :: CGI CGIResult
cgiMain = output "Hello World!"

main :: IO ()
main = runCGI (handleErrors cgiMain)

FastCGI

-- ghc -package fastcgi -threaded --make -o FCgiPlay.fcgi FCgiPlay.hs 
import Control.Concurrent
import System.Posix.Process (getProcessID)

import Network.FastCGI

test :: CGI CGIResult
test = do setHeader "Content-type" "text/plain"
          pid <- liftIO getProcessID
          threadId <- liftIO myThreadId
          let tid = concat $ drop 1 $ words $ show threadId
          output $ unlines [ "Process ID: " ++ show pid,
                             "Thread ID:  " ++ tid]

main = runFastCGIConcurrent' forkIO 10 test

Happstack on FastCGI

import Happstack.Server.FastCGI
import Happstack.Server.SimpleHTTP (askRq, getData, RqData, ToMessage)
import Happstack.Server (look, fromData, FromData, simpleHTTP, Conf(..), toResponse, ServerPartT)

simpleCGI :: (ToMessage a) => ServerPartT IO a -> IO ()
simpleCGI = runFastCGIConcurrent 10 . serverPartToCGI
 
main = simpleCGI handleRequest

handleRequest = return $ toResponse "Howdy From Happstack on FastCGI"

• Calling commit on a connection that had already been disconnected


• Trying read an int out of the textual representation of a

  Data.ByteString.Lazy.Char8

  and insert it into the database

Prelude.read: no parse

• Send out HTML


• Include data from the Database in the HTML


• Process input from a form


• Save the data to the db


• Do a redirect

case journalEntry of
  Just learned -> apply $ whatWas $ learned 
  Nothing -> getAClue $ readComments

I am most of the way through the exercises in Chapter 4, but am totally stalling on finishing. For some yak shaving goodness, I thought I would document the Query system and all the layers on top of Scheme which are need to implement this.

PLT Streams code is originally by Berthold K.P. Horn for 2007 class

I am starting from the bottom up... Without further ado

Doh, LJ doesn't allow iframe... so click to open in a new window SICP Streams Documentation.

Hopefully once I have it all documented in a Visual Language, then I can polish of the last questions quicker.

So I finished Section 3.4 on concurrency. Sorry no posts for 2.3 - 3.4. Study group has been going well and I have been playing with Scheme instead of writing summaries here... Doh!

An example:
Implementing a backtracking stategy in Scheme:

(define matrix
  #{
    #{40  53 216}
    #{252 52 85}
    #{150 36 70}
    })
(define (matrix-width)
  (vector-length (vector-ref matrix 0)))
(define (matrix-height)
  (vector-length matrix))
(define (energy@ matrix x y)
  ;(display (format "energy@ ~a ~a~n" x y))
  (vector-ref (vector-ref matrix y) x))
(define (energy@-test)
  (values
   (energy@ matrix 0 0)   ;=> 40
   (energy@ matrix 2 2))) ;=> 70

;problem - find lowest energy path from top row "0"
; to bottom row "2". A path can only go 1 space away
; so 0,1 (value 53 above) can go to
;1,0 (252)
;1,1 (52)
;1,2 (85)
; since they are the left, down, and right spaces from 0,1
;
; The lowest energy path is found by adding cells in path
; Example perhaps
; x:0,y:1    x:1,y:2    x:2,y:1  could have the lowest sum
; when we add up the values 53 + 85 + 36

(define (brute-find-lowest-no-cache)
  (define (column-iter n)
    (define (try-path x y solution)
      (if (or (or (>= y (matrix-height))
                  (< x 0))
              (>= x (matrix-width)))
          solution
          (let* ((try-left (> x 0))
                 (left-sum (if try-left 
                               (+ (try-path (- x 1) (+ 1 y) (energy@ matrix x y)) solution)
                               30000))
                 (try-down #t) ; see assertion below
                 (down-sum (if try-down 
                               (+ (try-path  x (+ 1 y) (energy@ matrix x y)) solution)
                               (error "Should never happen, can always go down without hitting an edge")))
                 (try-right (< x (- (matrix-width) 1)))
                 (right-sum (if try-right 
                                (+ (try-path (+ 1 x) (+ 1 y) (energy@ matrix x y)) solution)
                                30000)))
            (cond ((and try-left (and (< left-sum down-sum) (< left-sum right-sum)))
                   left-sum)
                  ((and try-right (and (< right-sum down-sum) (< right-sum left-sum)))
                   right-sum)
                  (else
                   down-sum)))))
    ;(display (format "Doing ~a~n" n))
    (if (>= n (matrix-width))
        0
        (begin
          ;(display (format "x=~a~n" n))
          (display (format "col ~a lowest=~a~n" n (try-path n 0 0)))
          (column-iter (+ 1 n)))))
  (column-iter 0))
;(brute-find-lowest-no-cache)

(define (get-cache-key x y)
  ;todo try sha-digest on this output, profile...
  (format "~a:~a" x y))
(define *cache* #f)
(define (brute-find-lowest)
  (let ((cache (make-hash-table 'equal)))
    (define (column-iter n)
      (define (try-path x y solution)
        (let* ((cache-key (get-cache-key x y))
               (cached-answer (hash-table-get cache cache-key #f)))
          (if cached-answer
              (begin
                ;(display (format "Using cached answer for cache-key=~a cached-answer=~a~n" cache-key cached-answer))
                (+ cached-answer solution))
              (if (or (or (>= y (matrix-height))
                          (< x 0))
                      (>= x (matrix-width)))
                  solution                  
                  (let* ((try-left (> x 0))
                         (left-sum (if try-left
                                       (let* ((new-solution                                                (try-path (- x 1) (+ 1 y) (energy@ matrix x y))) 
                                              
                                              (new-cache-key (get-cache-key x y)))
                                         ;(display (format "at ~a put ~a~n" new-cache-key new-solution))
                                         ;(hash-table-put! cache new-cache-key new-solution)
                                          new-solution )
                                       30000))
                         (try-down #t) ; see assertion below
                         (down-sum (if try-down 
                                       (let* ((new-solution
                                               (try-path  x (+ 1 y) (energy@ matrix x y)) 
                                               )
                                              (new-cache-key (get-cache-key x y)))
                                         ;(display (format "at ~a put ~a~n" new-cache-key new-solution))
                                         ;(hash-table-put! cache new-cache-key new-solution)
                                         new-solution
                                         )
                                       (error "Should never happen, can always go down without hitting an edge")))
                         (try-right (< x (- (matrix-width) 1)))
                         (right-sum (if try-right                                      
                                        (let* ((new-solution
                                                (try-path (+ x 1) (+ 1 y) (energy@ matrix x y)) 
                                                )
                                               
                                               (new-cache-key (get-cache-key x y)))
                                          ;(display (format "at ~a put ~a~n" new-cache-key new-solution))
                                          
                                          new-solution )
                                        30000)))
                    
                    (cond ((and try-left (and (< left-sum down-sum) (< left-sum right-sum)))
                           (hash-table-put! cache (get-cache-key x y) left-sum)
                           (+ left-sum solution))
                          ((and try-right (and (< right-sum down-sum) (< right-sum left-sum)))
                           (hash-table-put! cache (get-cache-key x y) right-sum)
                           (+ right-sum solution))
                          (else
                           (hash-table-put! cache (get-cache-key x y) down-sum)
                           (+ down-sum solution))))))))
      ;(display (format "Doing ~a~n" n))
      (if (>= n (matrix-width))
          0
          (begin
            ;(display (format "x=~a~n" n))
            ;(display (format "col ~a lowest=~a~n" n (try-path n 0 0)))
            (column-iter (+ 1 n)))))
    (column-iter 0)
    (set! *cache* cache)
    ))

(define lowest-seen 10000)
(define (backtracking-find-lowest)
  (define (column-iter n)
    (define (try-path x y solution-so-far)
      (if (or (or (or (>= y (matrix-height))
                      (< x 0))
                  (>= x (matrix-width)))
              (>= solution-so-far lowest-seen))
          solution-so-far
          
          (let* ((try-left (> x 0))
                 (left-sum (if try-left 
                               (+ (try-path (- x 1) (+ 1 y) (energy@ matrix x y)) solution-so-far)
                               30000))
                 (try-down #t) ; see assertion below
                 (down-sum (if try-down 
                               (+ (try-path  x (+ 1 y) (energy@ matrix x y)) solution-so-far)
                               (error "Should never happen, can always go down without hitting an edge")))
                 (try-right (< x (- (matrix-width) 1)))
                 (right-sum (if try-right 
                                (+ (try-path (+ 1 x) (+ 1 y) (energy@ matrix x y)) solution-so-far)
                                30000)))
            (cond ((and try-left (and (< left-sum down-sum) (< left-sum right-sum)))
                   left-sum)
                  ((and try-right (and (< right-sum down-sum) (< right-sum left-sum)))
                   right-sum)
                  (else
                   down-sum)))))
    ;(display (format "Doing ~a~n" n))
    (if (>= n (matrix-width))
        0
        (let ((solution (try-path n 0 0)))
          ;(display (format "x=~a~n" n))
          (if (< solution lowest-seen)
              (begin
                ;(display "New lowest ever")(newline)
                (set! lowest-seen solution)))
          (display (format "col ~a lowest=~a~n" n solution))
          (column-iter (+ 1 n)))))
  (column-iter 0))
;(backtracking-find-lowest)

So I coded up a brute force solution, a backtracking solution, and then backtracking with caching. In Land of the Lost terminology that is memoization which simply means caching results. Then I ran

(time-apply brute-find-lowest '())

backtracking.scm has the gory details including a real jpeg converted into an "energy map" for testing with a larger data set.