loop horror - or: How to do this better ?

Frank DG1SBG

unread,

Apr 6, 2014, 3:37:04 PM4/6/14

to

Hi all -

I have the following challenge:

Reading from a serial device (an amateur radio transceiver) I get back
character sequences like this:

(defparameter *test-response*
'( #\Nul #\Return #\$ #\P #\M #\U #\ #\ #\ #\2 #\1 #\Return #\Newline #\Nul #\$ #\P #\M #\U #\ #\ #\ #\2 #\0 #\Return #\Newline #\Nul #\$ #\P #\M #\U #\ #\ #\ #\1 #\9 #\Return #\Newline #\Nul #\$ #\P #\M #\U #\ #\ #\ #\1 #\8 #\Return #\Newline #\Nul))
;;; Test data for function cleanup-adat-response
;;; desired result:
;;; '("$PMU 21" "$PMU 20" "$PMU 19" "$PMU 18")

As you can see it is the goal to remove un-wanted characters like #\Nul,
#\Return etc. In addition each occurence of one of the characters #\Nul,
#\Return or #\Newline indicates the begin of a new string.

As a result a list of all identified strings shall be returned. With a
bit of fiddling I came up with this:

(defun cleanup-adat-response (response-list &optional (char-list (list #\Return #\Newline #\Nul)))
(let ((in-string nil)
(result (list))
(current-string ""))
(loop
for c in response-list
do
(format *debug-io* "~&----------------------------------------------------------------------------")
(format *debug-io* "~&Current char = ~s.~&" c)
(format *debug-io* "~&In string ? ~s.~&" in-string)
(format *debug-io* "~&Member c char-list? ~S~&" (member c char-list))

(format *debug-io* "~&Clause 1 logic value = ~s.~&"
(and (not in-string)
(member c char-list)))

(format *debug-io* "~&Clause 2 logic value = ~s.~&"
(and (not in-string)
(not (member c char-list))))

(format *debug-io* "~&Clause 3 logic value = ~s.~&"
(and in-string
(member c char-list)))

(format *debug-io* "~&Clause 4 logic value = ~s.~&"
(and in-string
(not (member c char-list))))

(cond

((and (not in-string)
(member c char-list))
(format *debug-io* "~&Clause 1 => Current String = '~a'.~&"
current-string)
nil) ;;; Do nothing

((and (not in-string)
(not (member c char-list)))
(progn
(setq in-string t)
(setq current-string
(concatenate 'string current-string (string c)))
(format *debug-io* "~&Clause 2 => Current String = '~a'.~&"
current-string)
c))

((and in-string
(member c char-list))
(progn
(setq in-string nil)
(setq result (append result (list current-string)))
(setq current-string "")
(format *debug-io* "~&Clause 3 => Current String = '~a'.~&"
current-string)
nil))

((and in-string
(not (member c char-list)))
(progn
(setq in-string t)
(setq current-string
(concatenate 'string current-string (string c)))
(format *debug-io* "~&Clause 4 => Current String = '~a'.~&"
current-string)
c))
))
result))

While this works it *seems* a bit 'inelegant' and slow. Any hint on how
to improve this? I want speed ...

Thx!

Kind regards

Frank

Paul Rubin

unread,

Apr 6, 2014, 4:28:04 PM4/6/14

to

Frank DG1SBG <dg1...@googlemail.com> writes:
> As you can see it is the goal to remove un-wanted characters like #\Nul,
> #\Return etc. In addition each occurence of one of the characters #\Nul,
> #\Return or #\Newline indicates the begin of a new string.

I'd use the split-at function from

http://lisp-search.acceleration.net/html/string-case.html

to chop the input list into smaller lists delimited by those special
characters. Then paste together the sub-lists into strings, and filter
out the delimiters. You can do the chopping by keeping a running
count of how many delimiter chars are seen in the input string.

Alberto Riva

unread,

Apr 6, 2014, 7:33:10 PM4/6/14

to

On 04/06/2014 03:37 PM, Frank DG1SBG wrote:
> Reading from a serial device (an amateur radio transceiver) I get back
> character sequences like this:
>
> (defparameter *test-response*
> '( #\Nul #\Return #\$ #\P #\M #\U #\ #\ #\ #\2 #\1 #\Return
#\Newline #\Nul #\$ #\P #\M #\U #\ #\ #\ #\2 #\0 #\Return #\Newline
#\Nul #\$ #\P #\M #\U #\ #\ #\ #\1 #\9 #\Return #\Newline #\Nul #\$
#\P #\M #\U #\ #\ #\ #\1 #\8 #\Return #\Newline #\Nul))
> ;;; Test data for function cleanup-adat-response
> ;;; desired result:
> ;;; '("$PMU 21" "$PMU 20" "$PMU 19" "$PMU 18")
>
>
> As you can see it is the goal to remove un-wanted characters
> like #\Nul, #\Return etc. In addition each occurence of one of
> the characters #\Nul, #\Return or #\Newline indicates the begin
> of a new string.
>
> As a result a list of all identified strings shall be returned.

(defun cleanup (chars &key (unwanted (list #\Nul #\Return #\Newline)))
(let ((result nil)
(o (make-string-output-stream)))
(dolist (ch chars)
(cond ((member ch unwanted :test #'char=)
(let ((w (get-output-stream-string o)))
(unless (string= w "")
(push w result))))
(t (princ ch o))))
(nreverse result)))

> (cleanup '( #\Nul #\Return #\$ #\P #\M #\U #\ #\ #\ #\2 #\1

#\Return #\Newline #\Nul #\$ #\P #\M #\U #\ #\ #\ #\2 #\0 #\Return
#\Newline #\Nul #\$ #\P #\M #\U #\ #\ #\ #\1 #\9 #\Return #\Newline
#\Nul #\$ #\P #\M #\U #\ #\ #\ #\1 #\8 #\Return #\Newline #\Nul))

("$PMU 21" "$PMU 20" "$PMU 19" "$PMU 18")

--
Alberto

Pascal J. Bourguignon

unread,

Apr 6, 2014, 10:41:58 PM4/6/14

to

Frank DG1SBG <dg1...@googlemail.com> writes:

> Hi all -
>
> I have the following challenge:
>
> Reading from a serial device (an amateur radio transceiver) I get back
> character sequences like this:
>
> (defparameter *test-response*
> '( #\Nul #\Return #\$ #\P #\M #\U #\ #\ #\ #\2 #\1 #\Return #\Newline #\Nul #\$ #\P #\M #\U #\ #\ #\ #\2 #\0 #\Return #\Newline #\Nul #\$ #\P #\M #\U #\ #\ #\ #\1 #\9 #\Return #\Newline #\Nul #\$ #\P #\M #\U #\ #\ #\ #\1 #\8 #\Return #\Newline #\Nul))
> ;;; Test data for function cleanup-adat-response
> ;;; desired result:
> ;;; '("$PMU 21" "$PMU 20" "$PMU 19" "$PMU 18")
>
>
> As you can see it is the goal to remove un-wanted characters like #\Nul,
> #\Return etc. In addition each occurence of one of the characters #\Nul,
> #\Return or #\Newline indicates the begin of a new string.

(defparameter *test-response*
'( #\Nul #\Return #\$ #\P #\M #\U #\ #\ #\ #\2 #\1 #\Return #\Newline #\Nul #\$ #\P #\M #\U #\ #\ #\ #\2 #\0 #\Return #\Newline #\Nul #\$ #\P #\M #\U #\ #\ #\ #\1 #\9 #\Return #\Newline #\Nul #\$ #\P #\M #\U #\ #\ #\ #\1 #\8 #\Return #\Newline #\Nul))

(ql:quickload :split-sequence)
(use-package :split-sequence)

(mapcar (lambda (list) (coerce list 'string))
(split-sequence #\Return
(remove-if (lambda (ch) (or (char= #\Nul ch)(char= #\Newline ch)))
*test-response*)
:remove-empty-subseqs t))
--> ("$PMU 21" "$PMU 20" "$PMU 19" "$PMU 18")

Now, since you probably receive the characters one by one, you could
filter out #\Nul and #\Newline before putting them on the list.

--
__Pascal Bourguignon__
http://www.informatimago.com/
"Le mercure monte ? C'est le moment d'acheter !"

Raymond Wiker

unread,

Apr 7, 2014, 1:57:14 PM4/7/14

to

I interpreted the Subject header to mean that you wanted a "loop
horror", so here's one:

(defun parse-response (response)
(flet ((break-token-p (token)
(member token '(#\Nul #\Return #\Newline) :test #'eql)))
(loop with string-builder = nil
for char in response
for is-break = (break-token-p char)
for collect-start = (and (not string-builder) (not is-break))
for collecting = (not is-break)
for collect-end = (and string-builder is-break)
when collect-start do (setf string-builder (make-string-output-stream))
when collecting do (write-char char string-builder)
when collect-end
collect (prog1 (get-output-stream-string string-builder)
(setf string-builder nil)))))

#||
(parse-response *test-response*)
||#

tar...@google.com

unread,

Apr 7, 2014, 6:36:44 PM4/7/14

to

| (cond
| ((and (not in-string)
| (member c char-list))

| c))
| ))
| result))

When you remove the debugging aids and restructure it a bit
it isn't all that bad looking:
(defun cleanup-adat-response (response-list &optional (delimiter-list '(#\Return #\Newline #\Nul)))
(let ((in-string nil)
(result nil)
(current-chars nil))

(loop
for c in response-list

do (if in-string
(if (member c delimiter-list)
(progn
(push (concatenate 'string (nreverse current-chars)) result)
(setq in-string nil
current-chars nil))
(push c current-chars))
(unless (member c delimiter-list)
(setq in-string t)
(push c current-chars)))
;; Handle the case where the last few characters aren't delimited:
finally (when (and in-string current-chars)
(push (concatenate 'string (nreverse current-chars)) result)))
(nreverse result)))

Frank DG1SBG

unread,

Apr 8, 2014, 5:53:20 AM4/8/14

to

Raymond Wiker <rwi...@gmail.com> writes:

> I interpreted the Subject header to mean that you wanted a "loop
> horror", so here's one:
>
> (defun parse-response (response)
> (flet ((break-token-p (token)
> (member token '(#\Nul #\Return #\Newline) :test #'eql)))
> (loop with string-builder = nil
> for char in response
> for is-break = (break-token-p char)
> for collect-start = (and (not string-builder) (not is-break))
> for collecting = (not is-break)
> for collect-end = (and string-builder is-break)
> when collect-start do (setf string-builder (make-string-output-stream))
> when collecting do (write-char char string-builder)
> when collect-end
> collect (prog1 (get-output-stream-string string-builder)
> (setf string-builder nil)))))
>
> #||
> (parse-response *test-response*)
> ||#

Wow - 10 bonus points for being a loop black belt ;-)

Thanks!

Frank

Frank DG1SBG

unread,

Apr 8, 2014, 5:59:10 AM4/8/14

to

Thanks to all responders. I am currently testing with very long response
strings...

Regards

Frank

Frank DG1SBG

unread,

Apr 8, 2014, 10:23:55 AM4/8/14

to

... clear winner: Raymond Wiker's variant using loop!
15k cpu cycles vs. > 1 million cpu cycles for all other solutions. This
was tested on SBCL 1.1.14 on Mac OS X.

Cheers
Frank

Raymond Wiker

unread,

Apr 8, 2014, 12:09:11 PM4/8/14

to

That's actually very impressive - and not because of my code. It's nice
to get the occasional reminder of how good sbcl (and its developers) is
at optimization.

His Kennyness

unread,

Apr 18, 2014, 10:59:18 AM4/18/14

to

On Sunday, April 6, 2014 3:37:04 PM UTC-4, Frank DG1SBG wrote:
> Hi all -
>
>
>
> I have the following challenge:
>
>
>
> Reading from a serial device (an amateur radio transceiver) I get back
>
> character sequences like this:
>
>
>
> (defparameter *test-response*
>
> '( #\Nul #\Return #\$ #\P #\M #\U #\ #\ #\ #\2 #\1 #\Return #\Newline #\Nul #\$ #\P #\M #\U #\ #\ #\ #\2 #\0 #\Return #\Newline #\Nul #\$ #\P #\M #\U #\ #\ #\ #\1 #\9 #\Return #\Newline #\Nul #\$ #\P #\M #\U #\ #\ #\ #\1 #\8 #\Return #\Newline #\Nul))
>
> ;;; Test data for function cleanup-adat-response
>
> ;;; desired result:
>
> ;;; '("$PMU 21" "$PMU 20" "$PMU 19" "$PMU 18")

Loop horror? And fast? Woo hoo!

(defparameter *test-response*
'( #\Nul #\Return #\$ #\P #\M #\U #\ #\ #\ #\2 #\1 #\Return #\Newline #\Nul #\$ #\P #\M #\U #\
#\ #\ #\2 #\0 #\Return #\Newline #\Nul #\$ #\P #\M #\U #\ #\ #\ #\1 #\9 #\Return
#\Newline #\Nul #\$ #\P #\M #\U #\ #\ #\ #\1 #\8 #\Return #\Newline #\Nul))

(defun test-response ()
(loop with s and o
for c in *test-response*

if (find c '(#\Nul #\Return #\Newline) :test 'char=)
do (when s
(push s o)
(setf s nil))

else do
(unless s
(setf s (make-array 0
:element-type 'character
:fill-pointer 0
:adjustable t)))
(vector-push-extend c s)

finally
(when s (push s o))
(return (reverse o))))

> (test-response)

Frank DG1SBG

unread,

Apr 19, 2014, 3:00:56 PM4/19/14

to

Hi Kenny,

that takes about 5 times the nr of cpu cycles of the best solution
(which I indicated in another post in this thread). So, no, not a winner
here.

;-)

Cheers
Frank

WJ

unread,

Jun 14, 2014, 1:18:51 AM6/14/14

to

> While this works it seems a bit 'inelegant' and slow. Any hint on how

> to improve this? I want speed ...
>
> Thx!
>
> Kind regards
>
> Frank

Racket:

(define test-response
'(#\Nul #\Return #\$ #\P #\M #\U #\ #\ #\ #\2 #\1

#\Return #\Newline #\Nul #\$ #\P #\M #\U #\ #\ #\ #\2 #\0
#\Return #\Newline #\Nul #\$ #\P #\M #\U #\ #\ #\ #\1 #\9
#\Return #\Newline #\Nul #\$ #\P #\M #\U #\ #\ #\ #\1 #\8
#\Return #\Newline #\Nul))

> (string-split (list->string test-response) (regexp "[\r\n\u0000]+"))

Alexander Skobelev

unread,

Jun 14, 2014, 11:47:11 PM6/14/14

to

With DOLIST you can write something like this:

(let ((delims '(#\Nul #\Return #\Newline))
chars result)

(dolist (ch *test-response* (nreverse result))
(if (member ch delims)
(when chars
(push (nreverse (coerce chars 'string)) result)
(setf chars '()))
(push ch chars))))