(define *graph* (read (open-input-file "test.sxml")))
(define get
(lambda (l)
(cond ((null? l) '())
((equal? 'opm:artifacts (car l)) l)
(else (get (cdr l))))))
(get *graph*)
I have this recursive function that goes through the list and returns the rest of a list that starts with "opm:artifacts".
It works on other lists.
For example, it works for the list (1 2 3 4); when I call the function,
(get 2) returns (2 3 4).
test.sxml is a list. I checked it with list?.
(define (get l)
(match l
[(? null?) '()]
[(list 'opm:artifacts _ ...) l]
[(list _ rs ...) (get rs)]))
(define (get mat ls*)
(define (get* ls)
(cond ((null? ls) '())
((and (list? (car ls)) (not (null? (car ls))))
(if (equal? mat (caar ls))
(car ls)
(let ((sub-result (get* (car ls))))
(if (null? sub-result)
(get* (cdr ls))
sub-result))))
(else (get* (cdr ls)))))
(let ((result (get* ls*)))
(if (null? result)
'()
(cdr result))))
(get 'b '(a (b c d) e)) ;-> '(c d)
(get 'b '((a (b c d) e))) ;-> '(c d)
(get '() '( 4 6 () (2 ()) (() () ()))) ;-> '(() ())
I've also generalized it so you can hand in what you want it to match against.
Related
My task is to get first atom in structure, that's why I'm used flatten and func "first-atom-lst". But there is one big problem - I need to handle pairs in structure and do NOT broke pairs. Can you please help me to handle this?
(define (check-improper? lst)
(cond
((null? lst) #f)
((number? lst) #f)
((atom? lst) #f)
((list? lst) #f)
((pair? (cdr lst)) #t)
(#t #f)
))
(define (improper-to-proper lst)
(cond
((null? lst) '())
((not (pair? (cdr lst))) (cons lst '()))
(else (cons (car lst) (improper-to-proper (cdr lst))))
)
)
(define (first-atom-from-pair lst)
(cond ((check-improper? lst))
((null? lst) #f)
((atom? (car (flatten lst)))
(car (flatten lst)))
(else
(first-atom (cdr (flatten lst))))))
(define (first-atom lst)
(cond ((check-improper? lst))
((null? lst) #f)
((atom? lst) lst)
((pair? (cdr lst)) (first-atom-from-pair lst))
((pair? lst) #f)
((atom? (car (flatten (not pair? lst))))
(car (flatten (not pair? lst))))
(else
(first-atom (cdr (flatten lst))))))
You cannot flatten improper lists, but it's actually overkill in your case anyway. You could do something like this:
(define (first-atom tree)
(if (null? tree)
#f
(if (pair? tree)
(first-atom (car tree))
tree)))
then
> (first-atom '((2 . 0) 2))
2
> (first-atom '((1 . 0) (2 . 3) 2))
1
> (first-atom '((2 . 1) (2 3) 1))
2
> (first-atom '(((((((1 . 2) 3) 4))))))
1
Note that my second result differs from yours, but I believe mine is correct since the first element of a flattened list would also yield 1.
Solve problem, but need improvement.
(define (atom? a)
(and (not (pair? a))
(not (null? a))))
(define (true-pair? p)
(cond
((list? p) #f)
((pair? (cdr p)) #f)
(else #t)))
(define (flatten-atom x)
(cond ((null? x) '())
((atom? x) (list x))
((true-pair? x) (list x))
(else (append (flatten-atom (car x))
(flatten-atom (cdr x))))))
(flatten-atom '((a b . c)))
(flatten-atom '((a b c) d e () ((f)) (1 . 2)))
(flatten-atom '((a b . c) (((4 5))) () 6 (7 . 8)))
> (a (b . c))
> (a b c d e f (1 . 2))
> (a (b . c) 4 5 6 (7 . 8))
I am writing a function to duplicate all the items in a list, so that a list like (a (b c)) becomes (a a (b b c c)), however my function returns (a a b b c c). How do I ensure I retain the internal list structure? Here is my current code:
(define double
(lambda (l)
(cond ((null? l) '())
((list? l) (append (double (car l)) (double (cdr l))))
(else (append (list l) (list l)) )
)
))
To preserve the structure of the list, you have to avoid using append. Here is an implementation:
(define (double lst)
(cond
[(null? lst) empty]
[(list? (car lst))
(cons (double (car lst))
(double (cdr lst)))]
[else
(cons (car lst) (cons (car lst)
(double (cdr lst))))]))
For example,
> (double '(a (b c) ((a b) (c d))))
'(a a (b b c c) ((a a b b) (c c d d)))
Shallow copy:
(define (copy-list lst)
(map values lst))
And of course map is like this for one list argument:
(define (map f lst)
(if (null? lst)
'()
(cons (f (car lst))
(map f (cdr lst)))))
Deep copy:
(define (copy-tree tree)
(accumulate-tree tree values cons '()))
And this is how accumulate-tree is made:
(define (accumulate-tree tree term combiner null-value)
(let rec ((tree tree))
(cond ((null? tree) null-value)
((not (pair? tree)) (term tree))
(else (combiner (rec (car tree))
(rec (cdr tree)))))))
I need to write a scheme function that returns as a function which then takes another argument, eg a list and in turn return the desired result. In this example (c?r "arg") would return -- (car(cdr -- which then subsequently takes the list argument to return 2
> ((c?r "ar") '(1 2 3 4))
2
> ((c?r "ara") '((1 2) 3 4))
2
The problem I have is how can I return a function that accepts another arg in petite?
Here's how you might write such a function:
(define (c?r cmds)
(lambda (lst)
(let recur ((cmds (string->list cmds)))
(if (null? cmds)
lst
(case (car cmds)
((#\a) (car (recur (cdr cmds))))
((#\d) (cdr (recur (cdr cmds))))
(else (recur (cdr cmds))))))))
Note that I'm using d to signify cdr, not r (which makes no sense, to me). You can also write this more succinctly using string-fold-right (requires SRFI 13):
(define (c?r cmds)
(lambda (lst)
(string-fold-right (lambda (cmd x)
(case cmd
((#\a) (car x))
((#\d) (cdr x))
(else x)))
lst cmds)))
Just wanted to add my playing with this. Uses SRFI-1.
(import (rnrs)
(only (srfi :1) fold)) ;; require fold from SRFI-1
(define (c?r str)
(define ops (reverse (string->list str)))
(lambda (lst)
(fold (lambda (x acc)
((if (eq? x #\a) car cdr) ; choose car or cdr for application
acc))
lst
ops)))
Its very similar to Chris' version (more the previous fold-right) but I do the reverseso i can use fold in the returned procedure. I choose which of car or cdr to call by looking at the character.
EDIT
Here is an alternative version with much more preprocessing. It uses tail-ref and list-tail as shortcuts when there are runs of #\d's.
(define (c?r str)
(let loop ((druns 0) (ops (string->list str)) (funs '()))
(cond ((null? ops)
(let ((funs (reverse
(if (zero? druns)
funs
(cons (lambda (x)
(list-tail x druns))
funs)))))
(lambda (lst)
(fold (lambda (fun lst)
(fun lst))
lst
funs))))
((eq? (car ops) #\d) (loop (+ druns 1) (cdr ops) funs))
((= druns 0) (loop 0 (cdr ops) (cons car funs)))
(else (loop 0 (cdr ops) (cons (lambda (x)
(list-ref x druns))
funs))))))
This can be made even simpler in #!racket. we skip the reverse and just do (apply compose1 funs).
(define (c?r str)
(let loop ((druns 0) (ops (string->list str)) (funs '()))
(cond ((null? ops)
(let ((funs (if (zero? druns)
funs
(cons (lambda (x)
(list-tail x druns))
funs))))
(apply compose1 funs)))
((eq? (car ops) #\d) (loop (+ druns 1) (cdr ops) funs))
((= druns 0) (loop 0 (cdr ops) (cons car funs)))
(else (loop 0 (cdr ops) (cons (lambda (x)
(list-ref x druns))
funs))))))
Assuming a compose procedure:
(define (compose funs . args)
(if (null? funs)
(apply values args)
(compose (cdr funs) (apply (car funs) args))))
(compose (list cdr car) '(1 2 3 4))
=> 2
c?r can be defined in terms of compose like so:
(define (c?r funs)
(lambda (e)
(compose
(map
(lambda (f) (if (char=? f #\a) car cdr))
(reverse (string->list funs)))
e)))
then
((c?r "ar") '(1 2 3 4))
=> 2
((c?r "ara") '((1 2) 3 4))
=> 2
I am getting "Error: Invalid lambda: (lambda (insert-all))."
(define permutations
(lambda (L)
(let
((insert-all
(lambda (e Ls)
(let
((insert-one
(lambda (L)
(letrec
((helper
(lambda(L R)
(if (null? R)
(list (append L(list e)R))
(helper (append L (list (car R) ) ) (cdr R) )
))))
(helper '() L)))))
(apply append(map insert-one Ls)))))))
(cond ((null? L) '() )
((null?(cdr L)) (list L))
(else (insert-all (car L) (permutations ((cdr L))))))))
It is supposed to return all permutations of a given list.
The form that you have provided in not valid scheme. Specifically, your highest-level let form does not have a body. You might be thinking that the cond clause is the body but owing to your parenthesis it is not part of the let. Honestly, this is the fault of your formatting. Here is a 'properly' formatted Scheme form:
(define (permutations L)
(let ((insert-all
(lambda (e Ls)
(let ((insert-one
(lambda (L)
(let helper ((L '()) (R L))
(if (null? R)
(list (append L (list e) R))
(helper (append L (list (car R)))
(cdr R)))))))
(apply append (map insert-one Ls))))))
(cond ((null? L) '())
((null? (cdr L)) (list L))
(else (insert-all (car L)
(permutations (cdr L)))))))
At least it compiles and runs, although it doesn't produce the right answer (although I don't know what the proper input it):
> (permutations '(a b c))
((c b a))
> (permutations '((a b) (1 2)))
(((1 2) (a b)))
Here is an implementation that works:
(define (permutations L)
(define (insert-all e Ls)
(apply append
(map (lambda (e)
(map (lambda (x) (cons e x)) Ls))
e)))
(cond ((null? L) '())
((null? (cdr L)) (map list (car L)))
(else (insert-all (car L)
(permutations (cdr L))))))
> (permutations '((a b) (1 2) (x y)))
((a 1 x) (a 1 y) (a 2 x) (a 2 y) (b 1 x) (b 1 y) (b 2 x) (b 2 y))
The basic structure of your code was fine; just the implementation of your insert-one and helper were lacking.
I'm trying to write a procedure that "encapsulates" (i.e. puts in a list) elements of a list between a "separator" element.
(my-proc '(1 + 2))
=> ((1) (2))
(my-proc '(x * y + z ^ 2 + 1 + 5))
=> ((x * y) (z ^ 2) (1) (5))
(my-proc '((x + 1) * y + 5))
=> (((x + 1) * y) (5))
In this case the procedure can be hard-coded to define the + symbol as the separator.
Assume that foldr (fold right operation) is defined, I'd prefer that it'd be in terms of it.
I'm not giving a full solution since this looks really homework-y.
(define (split-expr expr)
(foldr (lambda (e es)
(if (eq? e '+)
<???> ; do split
(cons (cons e (car es))
(cdr es))))
<???> ; what should start be?
es))
Just for fun, here's a version in continuation-passing style (no foldr, probably not suitable as a homework answer):
(define split/cps
(λ (sep ls)
(let loop ([ls ls] [k (λ (item acc)
(if item (cons item acc) acc))])
(cond
[(null? ls)
(k #f '())]
[(eq? sep (car ls))
(loop (cdr ls)
(λ (item acc)
(k #f (if item (cons item acc) acc))))]
[else
(loop (cdr ls)
(λ (item acc)
(k (if item
(cons (car ls) item)
(list (car ls)))
acc)))]))))
Here's another way to do it, also without foldr:
(define split/values
(λ (sep ls)
(let loop ([ls ls])
(cond
[(null? ls)
'()]
[else
(let-values ([(a d) (car-to-sep sep ls)])
(if (null? a)
(loop d)
(cons a (loop d))))]))))
(define car-to-sep
(λ (sep ls)
(let loop ([ls ls] [a '()])
(cond
[(null? ls)
(values '() '())]
[(eq? sep (car ls))
(values '() (cdr ls))]
[else
(let-values ([(a d) (loop (cdr ls) a)])
(values (cons (car ls) a) d))]))))