# Thread: Beginners Programming Challenge #20

1. A Carafe of Ubuntu
Join Date
Feb 2011
Location
Cambridge, ON, CAN
Beans
105
Distro
Ubuntu 10.10 Maverick Meerkat

## Re: Beginners Programming Challenge #20

That's very interesting. I've been starting to look at Haskell a little bit, and this gives me all the more reason to progress with it. Thanks for the time guys.

2. ## Re: Beginners Programming Challenge #20

Originally Posted by andrew1992
That's very interesting. I've been starting to look at Haskell a little bit, and this gives me all the more reason to progress with it. Thanks for the time guys.
Haskell is a very interesting language. Check out Learn You a Haskell for Great Good! for a pretty straightforward introduction.

3. Dipped in Ubuntu
Join Date
Feb 2009
Beans
530
Distro
Ubuntu 12.04 Precise Pangolin

## Re: Beginners Programming Challenge #20

Originally Posted by andrew1992
Your example doesn't help me see why those initial values are needed. Let's say you want to take the product of all the values in a list [1, 2, 3, 4, 5]. With my algorithm, an initial value isn't necessary.

[1, 2, 3, 4, 5]
[2, 3, 4, 5]
[6, 4, 5]
[24, 5]
120
In addition to what others have said, what happens if the list passed to your function is the empty list?

Reduce functions that specify an initial value just return the initial value in that case.

4. Dipped in Ubuntu
Join Date
Feb 2009
Beans
530
Distro
Ubuntu 12.04 Precise Pangolin

## Re: Beginners Programming Challenge #20

Here's an implementation in Haskell with filter, map, reverse (returns the list passed to it in opposite order), and a factorial function all implemented in terms of reduce.

(filter, map, and reverse are all already functions in Haskell Prelude, so I've added ' to the function names to distinguish them from the native versions).

Code:
```main = do
print (reduce (+) 0 [1..5]) {-add the numbers from 1 to 5-}
print (filter' odd [1..10]) {-print the odd numbers 1<=n<=10-}
print (map' (\x -> x*x) [1..10]) {-Print the squares of 1 to 10-}
print (reverse' [1..10]) {-Print 1 to 10 in reverse order-}
print (map' fac [0..9]) {-Print n factorial for 0<=n<=9-}

reduce :: (a -> b -> a) -> a -> [b] -> a
reduce _ i [] = i
reduce f i (x:xs) = reduce f (f i x) xs

filter' :: (a -> Bool) -> [a] -> [a]
filter' f xs = reduce (\ys y -> if f y then ys ++ [y] else ys) [] xs

map' :: (a -> b) -> [a] -> [b]
map' f xs = reduce (\ys y -> ys ++ [(f y)]) [] xs

reverse' :: [a] -> [a]
reverse' xs = reduce (\ys y -> y:ys) [] xs

fac :: Integer -> Integer
fac x = reduce (*) 1 [1..x]```

5. ## Re: Beginners Programming Challenge #20

A bump for more entries. Would anyone who's already made an entry like to try the extra credit?

6. ## Re: Beginners Programming Challenge #20

gforth implementation, gforth does not have a list type, so I had to implement
one.

Most list operations are done through maps, but note that there are
more than one type of map. Those that modifies the list, and those
that leave the list unmodified, like the map used for printing the
contents of a list.
Reduce is also done with a non-modifying map, but where the function that is applied takes two values from the stack* and leaves one.
In this way the first application of the function will operate on the
initial value and the first element, and leave the result on the stack
for the next iteration which will consume the previous result and the second
value in the list ...and so on...

*Forth is a stack-based language

Code:
```\ create a new node and pop the stack top
: +>node ( n -- a )
3 cells allocate throw
( n a )
0 over cell+ !
0 over 2 cells + !
dup -rot !
;

\ get the previous node address
: node- ( a[i] -- a[i-1] )
dup if cell+ @ then
;

\ get the next node address
: node+ ( a[i] -- a[i+1] )
dup if 2 cells + @ then
;

\ link two nodes together so that they point at each other
: cons ( a[i] a[i+1] -- a[i+1] )
dup if 2dup cell+ ! then
over if 2dup swap 2 cells + ! then
nip
;

\ break the link between two nodes
: uncons ( a[i] -- a[i-1] a[i] )
dup node-
dup if
dup 2 cells + 0 swap !
then
swap
dup if
dup cell+ 0 swap !
then
;

\ loop node- until the first node is found
: find-first ( a[i] -- a[0] )
dup ( ai ai )
begin
nip dup ( ai ai )
node- dup 0= ( ai ai-1 tf )
until
drop
;

\ loop node+ until the last node is found
: find-last ( a[i] -- a[N] )
dup
begin
nip dup
node+ dup 0=
until
drop
;

\ uncons node from prev and next and free the node
: -node ( a[i] -- a[i+1] )
uncons node+ uncons ( a[i-1] a[i] a[i+1] )
swap free throw ( a[i-1] a[i+1] )
cons ( a[i+1] )
;

\ apply an xt to all nodes in a list
: map \ ( a xt( a -- a ) -- )
begin
dup >r ( a[i] xt / xt)
execute ( a[i+1] / xt )
r> over ( a[i+1] xt a[i+1] )
0= until
2drop
;

\ Takes an xt (xti) with the stack effect ( n0 -- n1 )
\ and return an xt (xto) with the stack effect ( a0 -- a1 )
\ where a are node addresses.
\ The xti is included in xto so that the xti is applied to
\ the payload of a0 and the result (n1) is written back to a0
\ then a node+ is executed yielding a1
: rw-iter \ ( xt( n -- n ) -- xt( a -- a ) )
>r :noname r>
postpone dup postpone >r postpone @
( ... n ) compile, ( ... n )
postpone r@ postpone !
postpone r> postpone node+
postpone ; postpone immediate
;

\ same as rw-iter, but the expected stack effect of xti
\ is ( n -- ) and no data is written back to the node
\ good for printing the content of a list and such
: ro-iter \ ( xt( n -- ) -- xt( a -- a ) )
>r :noname r>
postpone dup postpone >r postpone @
( ... n ) compile, ( ... )
postpone r> postpone node+
postpone ; postpone immediate
;

\ also an iterator, but also expects another list node
\ on the stack, if the xt returns nonzero,
\ creates a new node with the data of the examined one
\ and conses the it onto this one
: cons-filter-iter
>r :noname r>
postpone dup postpone >r postpone @
( ... n ) compile, ( ... n )
postpone if
postpone r@ postpone @
postpone +>node
postpone cons
postpone then
postpone r> postpone node+
postpone ; postpone immediate
;

\ print a list
: .list ['] . [compile] ro-iter map ;

\ add 1 to all the elements of a list
: 1+list ['] 1+ [compile] rw-iter map ;

\ delete a list
: -list ['] -node map ;

\ copies the elements for which the xt returns nonzero
\ onto a new list
: filter
0 -rot [compile] cons-filter-iter map find-first
;

\ applies the xt onto the initial argument and the
\ first member of the list
\ the xt on the result of the above and the second element
\ ...
: reduce ( a n xt -- n )
[compile] ro-iter map
;

: even 2 mod 0= ;

: odd 2 mod 0<> ;

\ creates a list
: simple-list
1 +>node
26 2 do
i +>node cons
loop
find-first
;

\ creates a list of lists
: list-of-lists
11 +>node
10 2 do
10 i + +>node cons
loop
find-first
+>node
10 2 do
10 i * 1 + +>node
10 2 do
10 j * i + +>node cons
loop
find-first +>node cons
loop
find-first
;

\ examples

simple-list
." the contents of the test list:" cr
dup .list cr cr

." the even elements in the list:" cr
dup ' even filter
dup .list -list \ the result list is also freed from memory
cr cr

." the even elements in the list:" cr
dup ' odd filter
dup .list -list
cr cr

." the sum of the elements of the list:" cr
0 over ' + reduce . cr cr

." the product of the elements of the list:" cr
1 over ' * reduce . cr cr

." mapping a function that increases the values in the list" cr
dup ' 1+ rw-iter map
dup .list cr cr

-list

list-of-lists

\ the same as .list but with a carriage return on the end
: .row .list cr ;

." look! here we map another map on a list of lists :)" cr
dup ' .row ro-iter map cr

\ freeing the data is a question of first deleting the inner lists
dup ' -list ro-iter map
-list```
Shell/Output:
Code:
```leo@patternmaker:~/prog/forth
\$ gforth challenge20.fs
the contents of the test list:
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25

the even elements in the list:
2 4 6 8 10 12 14 16 18 20 22 24

the even elements in the list:
1 3 5 7 9 11 13 15 17 19 21 23 25

the sum of the elements of the list:
325

the product of the elements of the list:
2076180480

mapping a function that increases the values in the list
2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26

look! here we map another map on a list of lists :)
11 12 13 14 15 16 17 18 19
21 22 23 24 25 26 27 28 29
31 32 33 34 35 36 37 38 39
41 42 43 44 45 46 47 48 49
51 52 53 54 55 56 57 58 59
61 62 63 64 65 66 67 68 69
71 72 73 74 75 76 77 78 79
81 82 83 84 85 86 87 88 89
91 92 93 94 95 96 97 98 99

Gforth 0.7.0, Copyright (C) 1995-2008 Free Software Foundation, Inc.
Gforth comes with ABSOLUTELY NO WARRANTY; for details type `license'
Type `bye' to exit```

7. ## Re: Beginners Programming Challenge #20

Originally Posted by red_Marvin
gforth implementation, gforth does not have a list type, so I had to implement
one.
I don't know forth myself, but I've got a friend whose opinion I trust that I'll ask to take a look at this when judging comes around.

8. ## Re: Beginners Programming Challenge #20

He will probably say it is very horrible!

9. ## Re: Beginners Programming Challenge #20

Originally Posted by red_Marvin
He will probably say it is very horrible!
If you won again, they'd probably think we're colluding.

10. ## Re: Beginners Programming Challenge #20

common lisp has remove-if-not,

my own implementation

Code:
```(defun filter (fn lst)
(cond ((null (car lst)) nil)
(t (cons (if (funcall fn (car lst))
(car lst))
(filter fn (cdr lst))))))```
another way of doing it (longer but more correct output)

Code:
```(defun filter (fn lst)
(let ((final nil))
(labels ((main-loop (lst2)
(cond ((null (car lst2)) nil)
((funcall fn (car lst2))
(push (car lst2) final)
(main-loop (cdr lst2)))
(t (main-loop (cdr lst2))))))
(main-loop lst))
(reverse final)))```
reduce (must have a start value):

Code:
```(defun reduc (fn lst start)
(funcall fn (subseq lst start))```
extra credit:
Code:
```(defun sum (lst)
(cond ((null (car lst)) 0)
(t (+ (car lst)
(sum (cdr lst))))))

(defun cat (lsts)
(let ((final-list nil))
(mapcar (lambda (lst)
(mapcar (lambda (item)
(push item final-list))
lst))
lsts)
(reverse final-list)))

(defun rev (lst)
(let ((final-list nil))
(mapcar (lambda (item)
(push item final-list))
lst)
final-list))```
Code:
```* (reduc #'sum '(1 2 3 4 5) 0)

15
* (reduc #'sum '(1 2 3 4 5) 2)

12
* (filter #'oddp '(1 2 3 4 5))

(1 3 5)

* (sum '(1 2 3 4 5))

15
* (cat '((1 2 3 4 5) (6 7 8 9 0)))

(1 2 3 4 5 6 7 8 9 0)

* (rev '(1 2 3 4 5))

(5 4 3 2 1)```
Last edited by mo.reina; June 21st, 2011 at 12:36 PM.

#### Posting Permissions

• You may not post new threads
• You may not post replies
• You may not post attachments
• You may not edit your posts
•