I tried to write a program that counting down from 10 to 0 using Racket. It worked but the counting is going too fast, is there a way to implement a set time that count one second per turn? I've been working on it but couldn't find anyway. Thank for your time. Here's my code so far:
;; Functions:
;; countdown -> countdown
;; start the world with main at CTR-X CTR-Y
;;
(define (main cd)
(big-bang cd ; countdown
(on-tick advance-countdown) ; countdown -> countdown
(to-draw render) ; countdown -> Image
(on-key handle-key) ; countdown KeyEvent ->
countdown
(on-mouse handle-mouse))) ; Integer Integer MouseEvent
; -> countdown
;; countdown -> countdown
;; produce the next number by decrease by 1 from the previous number
(check-expect (advance-countdown 5) 4)
(check-expect (advance-countdown 0) 0)
;(define (advance-countdown cd) 0) ; stub
;;<use template from Countdown>
(define (advance-countdown cd)
(if (= cd 0)
0
(- cd 1)))
;; countdown -> Image
;; render ...
(check-expect (render 4) (place-image (text (number->string 4) TEXTSIZE
TEXT-COLOR) CTR-X CTR-Y MTS))
;(define (render cd) MTS) ; stub
(define (render cd)
(place-image (text (number->string cd) TEXTSIZE TEXT-COLOR)
CTR-X
CTR-Y
MTS))
;; countdown KeyEvent -> countdown
;; reset countdown to 10
(check-expect (handle-key 10 " ") 10)
(check-expect (handle-key 10 "a") 10)
;(define (handle-key cd ke) 0) ; stub
(define (handle-key cd ke)
(cond [(key=? ke " ") 10]
[else cd]))
What you are looking for is a 'Timer'. Racket has a few different notions of timer built into it, and you can even make your own. But two of the more prominent built in ones are:
timer% - from the racket/gui/base library, and
timer - from the web server library.
Or you could just make your own using alarm-evt and sync. (You can also make your own timer from more 'low level' primitives, but I would not recommend doing so, as its easy to make subtle mistakes and get the wrong time.
Since it looks like you are already using a gui (although the HTDP2 GUI rather than racket/gui), lets user timer%. Simply create a callback that decrements the timer, and stops when it reaches 0.
#lang racket
(require racket/gui/base)
(define count 10)
(displayln count)
(define the-timer
(new timer% [notify-callback
(lambda ()
(set! count (- count 1))
(displayln count)
(when (= count 0)
(send the-timer stop)))]
[interval 1000]))
Now, when you run this program, it should count from 10 to 0 1 second at a time. We can test this out with the current-milliseconds function. Simply grab the start time, the end time, and take the difference. When I ran this on my machine I got a total time of '10138' ms, or 10.138 seconds.
Related
I am trying to animate the word "floccinaucinihilipilification" letter by letter. Right now it displays the complete word in the animation window, but I am lost on how to animate it so it will count up from the first character to the last, looping back to 0.
(define LONG-WORD "floccinaucinihilipilification")
; cycle-spelling : String -> Image
; display an animation of a long
; word being spelled out
(define a (string-length LONG-WORD))
(define TXT
(text (substring LONG-WORD 0 a) 30 "black"))
(define BG
(empty-scene 400 400))
(define (cycle-spelling a)
(place-image TXT 200 200 BG))
(animate cycle-spelling)
See what animate does:
(animate create-image) → natural-number/c
create-image : (-> natural-number/c scene?)
opens a canvas and starts a clock that ticks 28 times per second. Every time the clock ticks, DrRacket applies create-image to the number of ticks passed since this function call. The results of these function calls are displayed in the canvas. The simulation runs until you click the Stop button in DrRacket or close the window. At that point, animate returns the number of ticks that have passed.
So you have to base your code on the number of ticks, passed to create-image function.
(animate cycle-spelling)
(define (cycle-spelling ticks) ... )
Start with (quotient ticks 28), value of this expression increases each second by 1.
Looping is created with modulo, so after some experimenting, you should have something like this:
(modulo (quotient ticks 28) (+ (string-length long-word) 1))
Rest of the code will be similar.
Following code animates given word letter by letter and then loops back to 0.
#lang racket
(require 2htdp/universe)
(require 2htdp/image)
(define long-word "floccinaucinihilipilification")
(define speed 3) ; try also 7, 14, 28 ...
(define bg
(empty-scene 400 400))
(define (cycle-spelling ticks)
(place-image (text (substring long-word 0
(modulo (quotient ticks speed)
(+ (string-length long-word) 1)))
30 "black")
200 200 bg))
(animate cycle-spelling)
I have the following function "change" which takes a certain amount of money to be paid, the size of the bill/coin used to pay, and returns a list with the number of "coins" ($50, $20 $10 $5 $2 and $1) one would receive after completing the transaction:
(define (change total payment)
(let [(x (- payment total))]
(change-aux x '(50 20 10 5 2 1))))
(define (change-aux change coins)
(cond
[(empty? coins) empty]
[else (let [(num-coins (floor (/ change (car coins))))]
(append (list num-coins)
(change-aux (- change (* (car coins) num-coins)) (cdr coins))))]))
So, if I input these parameters:
> (change 44 200)
It returns the output:
'(3 0 0 1 0 1)
That's 200-44 = 156, which corresponds to 3 coins worth $50, 1 worth $5 and 1 worth $1.
My question would be if there's a more elegant, simplified way to write a similar procedure without relying on auxiliary functions, and rather use lambda, filter, map, foldr, foldl etc?
Thanks in advance.
Here is a solution in a different Lisp dialect which shows how to do it with a left fold (reduce) without any mutation of an accumulator variable, as a kind of functional counterpoint to the existing solution.
(defun change (amount coins)
(reduce-left (tb ((counts . rem) next-coin)
(let* ((coin-count (floor rem next-coin))
(coin-value (* coin-count next-coin)))
(cons (cons coin-count counts)
(- rem coin-value))))
coins
(cons '() amount)))
3> (change 156 '(50 20 10 5 2 1))
((1 0 1 0 0 3) . 0)
4> (change 88 '(50 20 10 5 2 1))
((1 1 1 1 1 1) . 0)
Note that the values end up reported in reverse order and wrapped in an extra cons cell; a "porcelain" function could be used around this "plumbing" to report the result in the expected form.
The idea is that we have an accumulator which looks like this: (counts . remainder). The counts part of the accumulator stored in the car is the list of coins accumulated so far. When the reduce is done, this holds the final list. The cdr field holds the remaining amount to be processed; since the last coin is 1, this will always emerge as zero.
Using this accumulator structure, we process the list of coins.
On each call to our reduce kernel function, the left argument is the accumulator, and the right argument, next-coin, is the next coin denomination value.
I used a macro called tb ("tree bind") macro, which is a kind of lambda that provides built-in destructuring, to make it look like we have three parameters.
The initial value for the reduce job is the starting accumulator, which has an empty list of coins, and the full original amount: (cons nil amount) (which I rewrote to (cons '() amount) for better Scheme compatibility).
The reduce function is very simple: greedily calculate how many of the next coin value are needed to represent the remainder, and then calculate the new remainder, packaging these up into a new accumulator cons cell that is returned, and is passed to the next invocation of the function, or returned when the list of coin values has been processed.
Hopefully this points the way to "a more elegant, simplified way to write a similar procedure without relying on auxiliary functions, and rather use lambda, filter, map, foldr, foldl etc" that you can work out in Racket. Good luck!
Sure, you can.
Final solution
(define (change total payment (coins '(50 20 10 5 2 1)))
(let ((rest-diff (- payment total)))
(map (lambda (coin)
(let ((num-coins (floor (/ rest-diff coin))))
(set! rest-diff (- rest-diff (* num-coins coin)))
num-coins))
coins)))
Step by step
First of all, using inner define, you can get rid of the auxiliary function from the global namespace.
(define (change total payment)
(define (change-aux change coins)
(cond
[(empty? coins) empty]
[else (let [(num-coins (floor (/ change (car coins))))]
(append (list num-coins)
(change-aux (- change (* (car coins) num-coins)) (cdr coins))))]))
(let [(x (- payment total))]
(change-aux x '(50 20 10 5 2 1))))
Then, you can pull some variables of the helper function's to the global function's lambda list.
(define (change total payment (coins '(50 20 10 5 2 1)))
(define (change-aux change) ;; eliminate coins in the inner lambda list
(cond
[(empty? coins) empty] ;; coins in function body looked up from outer arguments
[else (let [(num-coins (floor (/ change (car coins))))]
(append (list num-coins)
(change-aux (- change (* (car coins) num-coins)) (cdr coins))))]))
(let [(x (- payment total))]
(change-aux x))) ;; eliminate coins in the call
Then, looking at the code of change-aux, one understands this is actually
a looping through and trying to fit maximal multiples of current value
into the rest of the difference remaining - and collecting those reults. One could loop using map and use set! to mutate the rest.
(define (change total payment (coins '(50 20 10 5 2 1)))
(let ((rest-diff (- payment total)))
(map (lambda (coin)
(let ((num-coins (floor (/ rest-diff coin))))
(set! rest-diff (- rest-diff (* num-coins coin)))
num-coins))
coins)))
Then, you call like above:
(change 44 200)
;; '(3 0 0 1 0 1)
Can you use 2 on-tick functions on 1 big bang? 1 Running at a default pace and the other a user-defined speed.
No. Providing more than one "on-tick" clause to big-bang results in an error: "big-bang: duplicate on-tick clause".
It is possible to have two time-based behaviors running at different speeds, both controlled by the same on-tick function.
For example, the two functions:
walk, which ticks every 5/10 seconds
run, which ticks every 2/10 second
Where run ticks at more than twice the speed of walk.
To do this, you set your "actual" tick speed to the "greatest common denominator" of the two, which in this case is every 1/10 second. Then you have to make sure run is called on every "actual" tick, and walk is called on every-other "actual" tick.
(define (actual-tick w)
???)
(big-bang ???
[on-tick actual-tick 1/10]
...)
How do you determine whether actual-tick should call walk or not? It should be called exactly 1/5 of the time, rotating between "on" "off" "off" "off" "off" regularly.
How do you determine whether actual-tick should call run or not? It should be called 1/2 of the time, alternating between "on" "off".
To do this you need to keep track of two numbers:
The number of ticks since the last "walk"
The number of ticks since the last "run"
These become the two fields in a structure in your world-state.
(struct ticks-since [run walk])
When to call "walk"? When the ticks-since-walk is 5.
(define (tick-walk? s)
(<= 5 (ticks-since-walk s)))
When to call "run"? When the ticks-since-run is 2.
(define (tick-run? s)
(<= 2 (ticks-since-run s)))
And finally the actual-tick function needs to call these.
(define (actual-tick s)
(cond
[(and (tick-walk? s) (tick-run? s))
;; call and reset both
(... walk ...
run ...
(ticks-since 0 0) ...)]
[(tick-walk? s)
;; call and reset walk, increment run
(... walk ...
(ticks-since 0 (add1 (ticks-since-run s))) ...)]
[(tick-run? s)
;; call and reset run, increment walk
(... run ...
(ticks-since (add1 (ticks-since-walk s)) 0) ...)]
[else
;; don't call walk or run, but increment both ticks-since counters
(... (ticks-since (add1 (ticks-since-walk s))
(add1 (ticks-since-run s))) ...)]))
I'm looking for something like #'delete-duplicates, but I know that all elements of the list are already sorted, or inversely sorted, or at least arranged so that duplicates will already be adjacent to each other. I wish to use that knowledge to ensure that execution speed is not proporational to the square of the number of elements in the list. It's trivial to use #'maplist to grow my own solution, but is there something already in the language? It would be embarrassing to reinvent the wheel.
To be clear, for largish lengths of lists, I would like the running time of the deletion to be proportional to the length of the list, not proportional to the square of that length. This is the behavior I wish to avoid:
1 (defun one-shot (cardinality)
2 (labels ((generate-list (the-count)
3 (let* ((the-list (make-list the-count)))
4 (do ((iterator 0 (1+ iterator)))
5 ((>= iterator the-count))
6 (setf (nth iterator the-list) iterator))
7 the-list)))
8 (let* ((given-list (generate-list cardinality))
9 (stripped-list)
10 (start-time)
11 (end-time))
12 (setf start-time (get-universal-time))
13 (setf stripped-list (delete-duplicates given-list :test #'eql))
14 (setf end-time (get-universal-time))
15 (princ "for n = ")
16 (princ cardinality)
17 (princ ", #'delete-duplicates took ")
18 (princ (- end-time start-time))
19 (princ " seconds")
20 (terpri))))
21 (one-shot 20000)
22 (one-shot 40000)
23 (one-shot 80000)
for n = 20000, #'delete-duplicates took 6 seconds
for n = 40000, #'delete-duplicates took 24 seconds
for n = 80000, #'delete-duplicates took 95 seconds
There's nothing like this in the language, but something like this makes just one pass through the list:
(defun delete-adjacent-duplicates (list &key key (test 'eql))
(loop
for head = list then (cdr head)
until (endp head)
finally (return list)
do (setf (cdr head)
(member (if (null key) (car head)
(funcall key (car head)))
(cdr head)
:key key :test-not test))))
As, #wvxvw pointed out, it might be possible to simplify this iteration using (loop for head on list finally (return list) do ...). However, 3.6 Traversal Rules and Side Effects says that modifying the cdr chain of a list during an object-traversal leads to undefined behavior. However, it's not clear whether loop for head on list is technically an object-traversal operation or not. The documentation about loop says in 6.1.2.1.3 The for-as-on-list subclause that
In the for-as-on-list subclause, the for or as construct iterates over
a list. … The
variable var is bound to the successive tails of the list in form1. At
the end of each iteration, the function step-fun is applied to the
list; the default value for step-fun is cdr. … The for or as construct
causes termination when the end of the list is reached.
This says that the step function is always applied at the end of the iteration, so it sounds like loop for head on list should be OK. At any rate, any possible issues could be avoided by using do loop instead:
(defun delete-adjacent-duplicates (list &key key (test 'eql))
(do ((head list (cdr head)))
((endp head) list)
(setf (cdr head)
(member (if (null key) (car head)
(funcall key (car head)))
(cdr head)
:key key :test-not test))))
The idea is to start with head being the list, then setting its cdr to the first tail that starts with a different element, then advancing the head, and continuing until there's nothing left. This should be linear in the length of the list, assuming that member is implemented in a sensible way. The use of member means that you don't have to do any extra work to get :key and :test working in the appropriate way. (Do note that :test for del-dups is going to be the :test-not of member.) Note: there's actually a slight issue with this, in that the key function will called twice for each element in the final list: once when it's the first element of a tail, and once when it's the car of head.
CL-USER> (delete-adjacent-duplicates (list 1 1 1 1 2 2 3 3 3))
(1 2 3)
CL-USER> (delete-adjacent-duplicates (list 1 2 2))
(1 2)
CL-USER> (delete-adjacent-duplicates (list 1 3 5 6 4 2 3 5) :key 'evenp)
(1 6 3)
I expect that any linear time solution is going to take a similar approach; hold a reference to the current head, find the next tail that begins with a different element, and then make that tail the cdr of the head.
I would expect REMOVE-DUPLICATES to have a linear time implementation. (And indeed it does* on my local SBCL install.)
Note that REMOVE-DUPLICATES and DELETE-DUPLICATES are specified to have the same return value, and that the side effects of DELETE-DUPLICATES are not guaranteed.
* The linear time code path is only taken when the :test is #'eq,#'eql, #'equal, or #'equalp (it relies on a hash table) and there is no :key or :test-not argument supplied.
For the record: your test code is basically just this:
(defun one-shot (n &aux (list (loop for i below n collect i)))
(time (delete-duplicates list))
(values))
It might also be useful to talk to the implementation maintainers in the case of a slow delete-duplicates.
For example (one-shot 1000000) runs in a second in CCL on my Mac. In LispWorks it runs in 0.155 seconds.
There is nothing like that in the language standard. However, you can do that either with a loop:
(defun remove-adjacent-duplicates (list &key (test #'eql))
(loop for obj in list
and prev = nil then obj
for take = t then (not (funcall test obj prev))
when take collect obj))
or with reduce (exercise left to the reader).
See the other answer for a destructive implementation.
PS. Unless you are doing something tricky with timing, you are much better off using time.
A bit different approach:
(defun compress-duplicates (list &key (test #'eql))
(labels ((%compress-duplicates (head tail)
(if (null tail)
(setf (cdr head) tail)
(progn (unless (funcall test (car head) (car tail))
(setf (cdr head) tail head (cdr head)))
(%compress-duplicates head (cdr tail))))))
(%compress-duplicates list (cdr list))
list))
(compress-duplicates (list 1 1 1 2 2 3 4 4 1 1 1))
;; (1 2 3 4 1)
Test of SBCL delete-duplicates implementation:
(defun test-delete-duplicates ()
(labels ((%test (list)
(gc)
(time (delete-duplicates list))))
(loop
:repeat 6
:for list := (loop :for i :from 0 :below 1000
:collect (random 100))
:then (append list list) :do (%test (copy-list list)))))
;; (test-delete-duplicates)
;; Evaluation took:
;; 0.002 seconds of real time
;; 0.002000 seconds of total run time (0.002000 user, 0.000000 system)
;; 100.00% CPU
;; 3,103,936 processor cycles
;; 0 bytes consed
;; Evaluation took:
;; 0.003 seconds of real time
;; 0.003000 seconds of total run time (0.003000 user, 0.000000 system)
;; 100.00% CPU
;; 6,347,431 processor cycles
;; 0 bytes consed
;; Evaluation took:
;; 0.006 seconds of real time
;; 0.006000 seconds of total run time (0.005000 user, 0.001000 system)
;; 100.00% CPU
;; 12,909,947 processor cycles
;; 0 bytes consed
;; Evaluation took:
;; 0.012 seconds of real time
;; 0.012000 seconds of total run time (0.012000 user, 0.000000 system)
;; 100.00% CPU
;; 25,253,024 processor cycles
;; 0 bytes consed
;; Evaluation took:
;; 0.023 seconds of real time
;; 0.022000 seconds of total run time (0.022000 user, 0.000000 system)
;; 95.65% CPU
;; 50,716,442 processor cycles
;; 0 bytes consed
;; Evaluation took:
;; 0.049 seconds of real time
;; 0.050000 seconds of total run time (0.050000 user, 0.000000 system)
;; 102.04% CPU
;; 106,747,876 processor cycles
;; 0 bytes consed
Shows linear speed.
Test of ECL delete-duplicates implementation:
;; (test-delete-duplicates)
;; real time : 0.003 secs
;; run time : 0.003 secs
;; gc count : 1 times
;; consed : 95796160 bytes
;; real time : 0.007 secs
;; run time : 0.006 secs
;; gc count : 1 times
;; consed : 95874304 bytes
;; real time : 0.014 secs
;; run time : 0.014 secs
;; gc count : 1 times
;; consed : 95989920 bytes
;; real time : 0.028 secs
;; run time : 0.027 secs
;; gc count : 1 times
;; consed : 96207136 bytes
;; real time : 0.058 secs
;; run time : 0.058 secs
;; gc count : 1 times
;; consed : 96617536 bytes
;; real time : 0.120 secs
;; run time : 0.120 secs
;; gc count : 1 times
;; consed : 97412352 bytes
Linear time increase too.
For Project Euler Problem 8, I am told to parse through a 1000 digit number.
This is a brute-force Lisp solution, which basically goes through every 5 consecutive digits and multiplies them from start to finish, and returns the largest one at the end of the loop.
The code:
(defun pep8 ()
(labels ((product-of-5n (n)
(eval (append '(*)
(loop for x from n to (+ n 5)
collect (parse-integer
1000digits-str :start x :end (+ x 1)))))))
(let ((largestproduct 0))
(do ((currentdigit 0 (1+ currentdigit)))
((> currentdigit (- (length 1000digits-str) 6)) (return largestproduct))
(when (> (product-of-5n currentdigit) largestproduct)
(setf largestproduct (product-of-5n currentdigit)))))))
It compiles without any warnings, but upon running it I get:
no non-whitespace characters in string "73167176531330624919225119674426574742355349194934...".
[Condition of type SB-INT:SIMPLE-PARSE-ERROR]
I checked to see if the local function product-of-5n was working by writing it again as a global function:
(defun product-of-5n (n)
(eval (append '(*)
(loop for x from n to (+ n 5)
collect (parse-integer
1000digits-str :start x :end (+ x 1))))))
This compiled without warnings and upon running it, appears to operate perfectly. For example,
CL_USER> (product-of-5n 1) => 882
Which appears to be correct since the first five digits are 7, 3, 1, 6 and 7.
As for 1000digits-str, it was simply compiled with defvar, and with Emacs' longlines-show-hard-newlines, I don't think there are any white-space characters in the string, because that's what SBCL is complaining about, right?
I don't think there are any white-space characters in the string, because that's what SBCL is complaining about, right?
The error-message isn't complaining about the presence of white-space, but about the absence of non-white-space. But it's actually a bit misleading: what the message should say is that there's no non-white-space in the specific substring to be parsed. This is because you ran off the end of the string, so were parsing a zero-length substring.
Also, product-of-5n is not defined quite right. It's just happenstance that (product-of-5n 1) returns the product of the first five digits. Strings are indexed from 0, so (product-of-5n 1) starts with the second character; and the function iterates from n + 0 to n + 5, which is a total of six characters; so (product-of-5n 1) returns 3 × 1 × 6 × 7 × 1 × 7, which happens to be the same as 7 × 3 × 1 × 6 × 7 × 1.
EVAL is not a good idea.
Your loop upper bound is wrong.
Otherwise I tried it with the number string and it works.
It's also Euler 8, not 9.
This is my version:
(defun euler8 (string)
(loop for (a b c d e) on (map 'list #'digit-char-p string)
while e maximize (* a b c d e)))
since I don't know common lisp, I slightly modified your code to fit with elisp. As far as finding bugs go and besides what have been said ((product-of-5n 1) should return 126), the only comment I have is that in (pep8), do length-4 instead of -6 (otherwise you loose last 2 characters). Sorry that I don't know how to fix your parse-error (I used string-to-number instead), but here is the code in case you find it useful:
(defun product-of-5n (n) ;take 5 characters from a string "1000digits-str" starting with nth one and output their product
(let (ox) ;define ox as a local variable
(eval ;evaluate
(append '(*) ;concatenate the multiplication sign to the list of 5 numbers (that are added next)
(dotimes (x 5 ox) ;x goes from 0 to 4 (n is added later to make it go n to n+4), the output is stored in ox
(setq ox (cons ;create a list of 5 numbers and store it in ox
(string-to-number
(substring 1000digits-str (+ x n) (+ (+ x n) 1) ) ;get the (n+x)th character
) ;end convert char to number
ox ) ;end cons
) ;end setq
) ;end dotimes, returns ox outside of do, ox has the list of 5 numbers in it
) ;end append
) ;end eval
) ;end let
)
(defun pep8 () ;print the highest
(let ((currentdigit 0) (largestproduct 0)) ;initialize local variables
(while (< currentdigit (- (length 1000digits-str) 4) ) ;while currentdigit (cd from now on) is less than l(str)-4
;(print (cons "current digit" currentdigit)) ;uncomment to print cd
(when (> (product-of-5n currentdigit) largestproduct) ;when current product is greater than previous largestproduct (lp)
(setq largestproduct (product-of-5n currentdigit)) ;save lp
(print (cons "next good cd" currentdigit)) ;print cd
(print (cons "with corresponding lp" largestproduct)) ;print lp
) ;end when
(setq currentdigit (1+ currentdigit)) ;increment cd
) ;end while
(print (cons "best ever lp" largestproduct) ) ;print best ever lp
) ;end let
)
(setq 1000digits-str "73167176531330624919")
(product-of-5n 1)
(pep9)
which returns (when ran on the first 20 characters)
"73167176531330624919"
126
("next good cd" . 0)
("with corresponding lp" . 882)
("next good cd" . 3)
("with corresponding lp" . 1764)
("best ever lp" . 1764)
I've done this problem some time ago, and there's one thing you are missing in the description of the problem. You need to read consequent as starting at any offset into a sting, not only the offsets divisible by 5. Therefore the solution to the problem will be more like the following:
(defun pe-8 ()
(do ((input (remove #\Newline
"73167176531330624919225119674426574742355349194934
96983520312774506326239578318016984801869478851843
85861560789112949495459501737958331952853208805511
12540698747158523863050715693290963295227443043557
66896648950445244523161731856403098711121722383113
62229893423380308135336276614282806444486645238749
30358907296290491560440772390713810515859307960866
70172427121883998797908792274921901699720888093776
65727333001053367881220235421809751254540594752243
52584907711670556013604839586446706324415722155397
53697817977846174064955149290862569321978468622482
83972241375657056057490261407972968652414535100474
82166370484403199890008895243450658541227588666881
16427171479924442928230863465674813919123162824586
17866458359124566529476545682848912883142607690042
24219022671055626321111109370544217506941658960408
07198403850962455444362981230987879927244284909188
84580156166097919133875499200524063689912560717606
05886116467109405077541002256983155200055935729725
71636269561882670428252483600823257530420752963450"))
(tries 0 (1+ tries))
(result 0))
((= tries 5) result)
(setq result
(max result
(do ((max 0)
(i 0 (+ 5 i)))
((= i (length input)) max)
(setq max
(do ((j i (1+ j))
(current 1)
int-char)
((= j (+ 5 i)) (max current max))
(setq int-char (- (char-code (aref input j)) 48))
(case int-char
(0 (return max))
(1)
(t (setq current (* current int-char))))))))
input (concatenate 'string (subseq input 1) (subseq input 0 1)))))
It's a tad ugly, but it illustrates the idea.
EDIT sorry, I've confused two of your functions. So that like was incorrect.