I have to rewrite this code using agents in someway the result of x is 0 (It means that each thread is executed one after one). But I have problems because I do not have enough knowledge about agents use.
The original code is:
(def x 0)
(let [t1 (Thread. #(dotimes [_ 10000] (def x (inc x))))
t2 (Thread. #(dotimes [_ 10000] (def x (dec x))))]
(.start t1)
(.start t2)
(.join t1)
(.join t2)
(println x))
When I want to use an agent with await(agent_name) to make each thread run separately, it does not work, the result is always different from zero.
Please any suggestions about this?
I gave this a try and it prints 0 as expected:
(ns agent-demo.core
(:gen-class))
(def counter
(agent 0))
(defn -main [& args]
(let [t1 (Thread. #(dotimes [_ 10000]
(send counter inc)))
t2 (Thread. #(dotimes [_ 10000]
(send counter dec)))]
(.start t1)
(.start t2)
(.join t1)
(.join t2)
(await counter)
(println #counter)
(shutdown-agents)))
Related
I need convert this code to Haskell. Please help me.
I would be very grateful for your help.
#lang scheme
(define (lab1 currentList counter result)
(let countdown ((i (- (length currentList) 1)))
(if (= i 0)
(display result)
(begin
(if (list? (list-ref currentList i))
(if (> (+ 1 counter) result)
(begin
(set! counter (+ 1 counter))
(set! result (+ 1 result))
(countdown(- i 1)))
(begin
(set! counter (+ 1 counter))
(countdown(- i 1))))
(begin
(set! counter 0)
(countdown(- i 1))))))))
I think I need to use something like:
data PolarBear a = P a | B [PolarBear a]
task :: [PolarBear a] -> Int
task [] = 0
task ((P _):ps) = task ps
task ((B p):ps) | null p = 1 + task ps
| otherwise = task ps + (task p)
main = task $ [B [ P 1, B [], B [ P 2, B [ P 3, B [], B []]]]]
?
As molbdnilo indicated, that's a really wretched excuse for Scheme code. To really get a feel for translating Scheme to Haskell, you should first make versions of counter and result that are bound in the countdown named let and updated on each pass without using set!.
(define (lab1 currentList counter0 result0)
(let countdown
((i (- (length currentList) 1))
(counter counter0)
(result result0))
(if (= i 0)
(display result)
(if (list? (list-ref currentList i))
(if (> (+ 1 counter) result)
(countdown (- i 1) (+ 1 counter) (+ 1 result))
(countdown (- i 1) (+ 1 counter) result))
(countdown (- i 1) 0 result)))))
Once you've done that, you can expand the named let out into a local recursive function. Remember that
(let loop ((x x0)) body)
is basically the same as
(letrec ((loop (lambda (x) body)))
(loop x0))
Once you've done that, the translation to Haskell should be pretty much immediate. It will be really bad Haskell code, because Haskell's !! is every bit as horribly inefficient as Scheme's list-ref (Will Ness shows how to do it much better), but it will faithfully reproduce the original code's behavior and (terrible) performance.
The thing to notice in your code is that it processes the input list from back to front, passing the info along in the same direction (in two variables). This is the same as what foldr does, when the combining function is strict in its second argument.
The pair which is the second argument to the combining function emulates the updatable "environment" for the two vars in Scheme.
I'm leaving spaces to be filled, since it's a homework.
lab1 ... = ... $
foldr (\x (counter,result)->
if (listP x)
then (if counter >= result
then (counter+1,result+1)
else (counter+1,result))
else (0,result)) (....,....) currentlist
assuming a datatype to which there exists a listP predicate returning a Boolean result. Like e.g.
data NestedList a = Atom a | List [NestedList a]
with
listP (Atom _) = ...
listP (...) = ...
If you need to present an explicitly recursive code, you need to write down the definition for foldr, and fuse it with the definition for the combining function above (let's call it g), turning
foldr g ... = ...
into
foldr_g ... = ...
then just renaming the foldr_g to your liking. The postprocessing step can go into a separate, "interface" function. Like so,
foldr_g z [] = z
foldr_g z (x:xs) = -- g x (foldr_g z xs)
g x r
where
r = foldr_g z xs
g x (counter, result)
| listP x = if counter >= result then ... else ...
| otherwise = ....
Actually inline the definition of g into the foldr_g by interchanging the code lines and smashing the two definitions together, as
foldr_g z [] = z
foldr_g z (x:xs) -- g x (foldr_g z xs)
-- g x r
| listP x = if counter >= result then ... else ...
| otherwise = ....
-- where
-- r = foldr_g z xs
where
(counter, result) = foldr_g z xs
and we call it as
lab1 currentList counter result =
... (foldr_g (...,...) currentlist)
I'm writing a scheme program that allows a user to create planets that follow gravitational laws. For the assignment, I have to alter the code to avoid busy waiting and also create a new thread for each planet, or every time that the mouse is clicked. I don't have a good understanding of GUIs in scheme, and would be very thankful for some help.
Here is the code:
#lang racket
(require racket/gui)
;; Small 2d vector library for the Newtonian physics
(define (x v) (vector-ref v 0))
(define (y v) (vector-ref v 1))
(define (x! v value) (vector-set! v 0 value))
(define (y! v value) (vector-set! v 1 value))
(define (v* v value) (vector-map (lambda (x) (* x value)) v))
(define (v+ v w) (vector-map + v w))
(define (v- v w) (vector-map - v w))
(define (v-zero! v) (vector-map! (lambda (x) 0) v))
(define (v-dot v w) (let ((vw (vector-map * v w))) (+ (x vw) (y vw))))
(define (v-mag v) (sqrt (v-dot v v)))
;; Planet object
(define planet%
(class object%
(public m p v calculate-force move draw)
(init-field (mass 1)
(position (vector 0 0 ))
(velocity (vector 0 0 ))
(force (vector 0 0 )))
(define (m) mass)
(define (p) position)
(define (v) velocity)
;; Use Newton's law of gravitation.
;; I assume the gravitational constant is one
(define (calculate-force pl)
(v-zero! force)
(for-each (lambda (other-planet)
(when (not (equal? this other-planet))
(let* ((direction (v- (send other-planet p) position))
(dist (max 1 (v-mag direction)))
(other-mass (send other-planet m))
(new-force (v* direction (/ (* mass other-mass) (* dist dist))))
)
(vector-map! + force new-force))))
pl)
)
;; Simple Euler integration of acceleration and velocity
(define (move)
(let ((acc (v* force (/ 1.0 mass))))
(vector-map! + velocity acc)
(vector-map! + position velocity)))
;; Draw a circle
(define (draw dc)
(send dc set-brush brush)
(send dc set-pen pen)
(send dc draw-ellipse (x position) (y position) radius radius ))
;; Initialize to random velocity, mass, and color
(x! velocity (* 2 (random)))
(y! velocity (* 2 (random)))
(set! mass (+ 1 (* 10 (random))))
(define radius (* 5 (sqrt mass)))
(define color
(let* ((r (random))
(b (real->floating-point-bytes r 4)))
(make-object color% (bytes-ref b 0) (bytes-ref b 1) (bytes-ref b 2) )))
(define brush (make-object brush% color))
(define pen (make-object pen% color))
;; Don't forget the super-new!
(super-new)
))
;; Abstract the list-handling for a list of planets
(define planet-container%
(class object%
(public add-planet calculate-force move draw get-planets)
(init-field (planets '()))
(define (get-planets) planets)
(define (add-planet planet)
(set! planets (cons planet planets)))
(define (calculate-force)
(for-each (lambda (planet)
(send planet calculate-force planets))
planets))
(define (move)
(for-each (lambda (planet)
(send planet move))
planets))
(define (draw dc)
(for-each (lambda (planet)
(send planet draw dc))
planets))
(super-new)
)
)
(define planet-container (new planet-container%))
;; The GUI
(define frame (new frame%
(label "Planets")
(min-width 120)
(min-height 80)
))
(send frame create-status-line)
(send frame show #t)
(define h-panel
(new horizontal-panel%
(parent frame)
(stretchable-height #f)
(style '(border))
(border 2)))
(define run-checkbox
(new check-box%
(parent h-panel)
(label "Run animation")
))
(define my-canvas%
(class canvas%
(override on-paint on-event)
(define (on-paint)
(let ((dc (send this get-dc))
(w (send this get-width))
(h (send this get-height)))
(send dc clear)
(send planet-container draw dc)
))
(define (on-event event)
(when (send event button-down?)
(let ((x (send event get-x))
(y (send event get-y)))
(send frame set-status-text (format "Mouse at ~a ~a" x y))
(send planet-container add-planet (new planet% (position (vector x y))))
(send this refresh)))
)
(super-new)
(send (send this get-dc) set-background (make-object color% 8 8 64))
))
(define canvas
(new my-canvas%
(parent frame)
(style '(border))
(min-width 640)
(min-height 480)))
;; Busy loop planet animator
(let loop ()
(sleep/yield .05)
(when (send run-checkbox get-value)
(send planet-container calculate-force)
(send planet-container move)
(send canvas refresh)
)
(loop))
Here's the crucial bit of code:
(define ch (make-channel))
(define run-checkbox
(new check-box%
(parent h-panel)
(label "Run animation")
[callback (λ _ (channel-put ch (send run-checkbox get-value)))]))
(thread (λ ()
(define moving? #f)
(let loop ()
;; either get a message on ch, or wait for 50 ms
(define r (sync ch (alarm-evt (+ (current-inexact-milliseconds) 50))))
;; if we got a message, update the state
(when (boolean? r) (set! moving? r))
;; move things if necessary
(when moving?
(send planet-container calculate-force)
(send planet-container move)
(send canvas refresh))
(loop))))
We first create a channel to communicate between the checkbox and the update thread.
Then, whenever there's a click on the checkbox, we send the value of the checkbox over the channel.
In the thread, we keep track of whether we're moving or not with the moving? variable. The thread simply sits in a loop updating the canvas whenever we're in the "moving" state.
To check for new messages, we use sync. The call to sync will return a result either if there's a message on ch (either #t or #f) or the alarm-evt finishes (in 50 milliseconds). If we actually got a message, ie a boolean message on the channel, we update which state we're in, update the canvas if necessary, and go back around the loop.
I'm writing a scheme program for an assignment that creates "planets" when the user clicks, and starts/stops the planets from orbiting each other when a checkbox is clicked. We are supposed to implement this with a thread. However, thread-suspend does not seem to work when I click the checkbox, but resume does.
Thanks for any help you can offer! Here is the code:
#lang racket
(require racket/gui)
(require racket/block)
;; Small 2d vector library for the Newtonian physics
(define (x v) (vector-ref v 0))
(define (y v) (vector-ref v 1))
(define (x! v value) (vector-set! v 0 value))
(define (y! v value) (vector-set! v 1 value))
(define (v* v value) (vector-map (lambda (x) (* x value)) v))
(define (v+ v w) (vector-map + v w))
(define (v- v w) (vector-map - v w))
(define (v-zero! v) (vector-map! (lambda (x) 0) v))
(define (v-dot v w) (let ((vw (vector-map * v w))) (+ (x vw) (y vw))))
(define (v-mag v) (sqrt (v-dot v v)))
(define sem (make-semaphore))
;; Planet object
(define planet%
(class object%
(public m p v calculate-force move draw)
(init-field (mass 1)
(position (vector 0 0 ))
(velocity (vector 0 0 ))
(force (vector 0 0 )))
(define (m) mass)
(define (p) position)
(define (v) velocity)
;; Use Newton's law of gravitation.
;; I assume the gravitational constant is one
(define (calculate-force planet-list)
(v-zero! force)
(for-each (lambda (other-planet)
(when (not (equal? this other-planet))
(let* ((direction (v- (send other-planet p) position))
(dist (max 1 (v-mag direction)))
(other-mass (send other-planet m))
(new-force (v* direction (/ (* mass other-mass) (* dist dist))))
)
(vector-map! + force new-force))))
planet-list)
)
;; Simple Euler integration of acceleration and velocity
(define (move)
(let ((acc (v* force (/ 1.0 mass))))
(vector-map! + velocity acc)
(vector-map! + position velocity)))
;; Draw a circle
(define (draw dc)
(send dc set-brush brush)
(send dc set-pen pen)
(send dc draw-ellipse (x position) (y position) radius radius ))
;; Initialize to random velocity, mass, and color
(x! velocity (random))
(y! velocity (random))
(set! mass (+ 1 (* 10 (random))))
(define radius (* 5 (sqrt mass)))
(define color
(let* ((r (random))
(b (real->floating-point-bytes r 4)))
(make-object color% (bytes-ref b 0) (bytes-ref b 1) (bytes-ref b 2) )))
(define brush (make-object brush% color))
(define pen (make-object pen% color))
;; Don't forget the super-new!
(super-new)
))
;; Abstract the list-handling for a list of planets
(define planet-list%
(class object%
(public add-planet calculate-force move draw)
(init-field (planets '()))
(define (add-planet planet)
(set! planets (cons planet planets)))
(define (calculate-force)
(for-each (lambda (planet)
(send planet calculate-force planets))
planets))
(define (move)
(for-each (lambda (planet)
(send planet move))
planets))
(define (draw dc)
(for-each (lambda (planet)
(send planet draw dc))
planets))
(super-new)
)
)
(define planet-list (new planet-list%))
;; The GUI
(define frame (new frame%
(label "Planets")
(min-width 120)
(min-height 80)
))
(send frame create-status-line)
(send frame show #t)
(define h-panel
(new horizontal-panel%
(parent frame)
(stretchable-height #f)
(style '(border))
(border 2)))
(define run-checkbox
(new check-box%
(parent h-panel)
(label "Run animation")
(callback
(lambda (button event)
(cond [(send run-checkbox get-value)(thread-resume (thread-a))]
[(not (send run-checkbox get-value)) (thread-suspend (thread-a))]
)))
))
(define my-canvas%
(class canvas%
(override on-paint on-event)
(define (on-paint)
(let ((dc (send this get-dc))
(w (send this get-width))
(h (send this get-height)))
(send dc clear)
(send planet-list draw dc)
))
(define (on-event event)
(when (send event button-down?)
(let ((x (send event get-x))
(y (send event get-y)))
(send frame set-status-text (format "Mouse at ~a ~a" x y))
(send planet-list add-planet (new planet% (position (vector x y))))
(send this refresh)))
)
(super-new)
(send (send this get-dc) set-background (make-object color% 8 8 64))
))
(define canvas
(new my-canvas%
(parent frame)
(style '(border))
(min-width 640)
(min-height 480)))
;; planet animator
(define thread-a (lambda ()
(let loop ()
(sleep/yield .1)
(send planet-list calculate-force)
(send planet-list move)
(send canvas refresh)
(loop))))
; this creates the thread-a and starts the program
(thread-suspend (thread thread-a))
It's actually miraculous that you got this working as much as it does.
The problem is that thread-a is not a thread. It's not a function that produces a thread. It's a function that runs forever, moving planets around and updating the canvas.
So when your checkbox's callback does (thread-suspend (thread-a)), for example, the thread-suspend never actually happens. The call to thread-a just starts running and never returns.
The reason the GUI doesn't lock up (which it normally would if an event callback didn't return) is that thread-a periodically calls sleep/yield, which allows the GUI event loop to process more events. (That's why I said the code is miraculous.)
The fix is to define thread-a as the thread itself:
(define thread-a
(thread
(lambda ()
(let loop () ....))))
(thread-suspend thread-a)
and change the other references from (thread-a) to just thread-a.
We have some functions needed to be called at any time and places. For example:
(defun winG (qty pb ps)
(- (* qty ps (- 1 SXF YHS)) (* 2 GHF) (* qty pb (+ 1 SXF))))
(defun winQ (qty pb ps)
(- (* qty ps (- 1 SXF)) (* 2 GHF) (* qty pb (+ 1 SXF))))
(defun stopLoss (qty pb &optional (lossRate 0.02))
(let ((tot (* qty pb (+ 1 SXF))))
(format t "Stop Loss at:~$~%" (- pb (/ (* tot lossRate) qty)))
(format t "Lost Money:~$(~d%)~%" (* tot lossRate) (* 100 lossRate))))
(defun div618 (p1 p2)
(let ((ratio '(0. 0.191 0.236 0.382 0.5 0.618 0.809 1.))
(price #'(lambda (r) (if (<= p1 p2) (+ p1 (* (- p2 p1) r)) (- p1 (* (- p1 p2) r))))))
(if (<= p1 p2)
(dolist (r (reverse ratio)) (format t "-------~3$ ~$-------~%" r (funcall price r)))
(dolist (r ratio) (format t "-------~3$ ~$-------~%" r (funcall price r))))))
Now we use stumpwm which can load our functions once started and we can call those functions just by striking hot key to open its eval window at any time and places. It is VERY convenient. However, the stumpwm is not VERY steady as xmonad. So we want to use xmonad instead of stumpwm and we donot mind to implement those Common Lisp functions using haskell.
Any suggestion is appreciated!
you should be able to do this via something like this
myKeys conf#(XConfig {XMonad.modMask = modm}) = M.fromList $
[ ((modm, xK_F1 ), spawn $ XMonad.terminal conf) --starts the terminal
, ((mod4Mask,xK_F1 ), spawn "gvim" >> -- you can concatenate commands too
spawn "notify-send -t 1000 gVim" >>
focusUrgent) -- or haskell functions
, ((mod4Mask,xK_F2 ), spawn "lisp evaluate lispy function")
, ((modm, xK_F3 ), haskellFunctionPortedFromLisp )]
hope this helps.
I fully understand the use of list in lisp but I 've got problem using string.
I try to write my own code of functions like string> or string< from common lisp to understand how lisp deals with string.
For example, abcde is bigger than abbb and returns 1.
I think that I will use the char function or do you think that I must use subseq ? or function that deals with ASCII code ?
Here are cases that I found :
-character 0 of each string are equal, we continue, with the next character.
-charactere 0 are different, one is smaller that other, we stop.
I need help about "go to the next character".
Thanks a lot !!
This is the Common Lisp version. You can just use ELT because
(type-of "a") => (SIMPLE-ARRAY CHARACTER (1))
(defun my-string< (a b &key (start 0))
(cond
((= start (length a) (length b))
nil)
((>= start (min (length a) (length b)))
(error "Undefined"))
((char= (elt a start) (elt b start))
(my-string< a b :start (1+ start)))
((char< (elt a start) (elt b start))
t)))
This is an implementation of a function that given two strings will return either -1, 0 or +1 depending on if the first is less than, equal or greater than the second.
In case one string is the initial part of the other then shorter string is considered to be "less than" the longer.
The algorithm is very simple... loops for every char until either the index gets past one of the strings or if a character is found to be different.
(defun strcmp (a b)
(do ((i 0 (1+ i))
(na (length a))
(nb (length b)))
((or (= i na) (= i nb) (char/= (elt a i) (elt b i)))
(cond
((= i na nb) 0) ;; Strings are identical
((= i na) -1) ;; a finished first
((= i nb) 1) ;; b finished first
((char< (elt a i) (elt b i)) -1) ;; Different char a < b
(t 1))))) ;; Only remaining case
(defun test (a b)
(format t "(strcmp ~s ~s) -> ~s~%"
a b (strcmp a b)))
(test "abc" "abc")
(test "ab" "abc")
(test "abc" "ab")
(test "abd" "abc")
(test "abc" "abd")
The output is
(strcmp "abc" "abc") -> 0
(strcmp "ab" "abc") -> -1
(strcmp "abc" "ab") -> 1
(strcmp "abd" "abc") -> 1
(strcmp "abc" "abd") -> -1
Your problem has been solved already but in case you run into others,
the following method might be useful:
I installed SBCL from source and keep the source around.
That allows me to run M-. on a function name like string<
and it will jump to the definition in your lisp implementation.
In my case I ended up at this macro:
;;; LESSP is true if the desired expansion is for STRING<* or STRING<=*.
;;; EQUALP is true if the desired expansion is for STRING<=* or STRING>=*.
(sb!xc:defmacro string<>=*-body (lessp equalp)
(let ((offset1 (gensym)))
`(with-two-strings string1 string2 start1 end1 ,offset1 start2 end2
(let ((index (%sp-string-compare string1 start1 end1
string2 start2 end2)))
(if index
(cond ((= (the fixnum index) (the fixnum end1))
,(if lessp
`(- (the fixnum index) ,offset1)
`nil))
((= (+ (the fixnum index) (- start2 start1))
(the fixnum end2))
,(if lessp
`nil
`(- (the fixnum index) ,offset1)))
((,(if lessp 'char< 'char>)
(schar string1 index)
(schar string2 (+ (the fixnum index) (- start2 start1))))
(- (the fixnum index) ,offset1))
(t nil))
,(if equalp `(- (the fixnum end1) ,offset1) nil))))))
) ; EVAL-WHEN
There is no direct concept of iteration ("next") with strings, in Scheme. That only applies to lists. So instead you have to iterate with indices:
(define (string<? lhs rhs)
(let* ((lhslen (string-length lhs))
(rhslen (string-length rhs))
(minlen (min lhslen rhslen)))
(let loop ((i 0))
(if (= i minlen) (< lhslen rhslen)
(let ((lhschar (string-ref lhs i))
(rhschar (string-ref rhs i)))
(cond ((char<? lhschar rhschar) #t)
((char<? rhschar lhschar) #f)
(else (loop (+ i 1)))))))))