This repository has been archived on 2023-08-20. You can view files and clone it, but cannot push or open issues or pull requests.
yap-6.3/packages/real/examples/for_real.pl
2015-10-13 08:25:49 +01:00

691 lines
16 KiB
Prolog
Raw Blame History

This file contains ambiguous Unicode characters

This file contains Unicode characters that might be confused with other characters. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

:- ensure_loaded( library(real) ).
:- ensure_loaded( library(lists) ).
:- use_module( library(apply_macros) ).
:- use_module( library(readutil) ).
:- set_prolog_flag(double_quotes, string).
% for_real.
%
% Some examples illustrating usage of the r..eal library.
for_real :-
( Head = ex(_Ex); Head = tut(_Tut) ),
clause( Head, Body ),
write(running:Head), nl, nl,
portray_clause( (Head:-Body) ), nl, nl,
write( 'Output: ' ), nl,
( catch(Head,Exc,Fex=true) ->
( Fex==true->
write( '! ' ), write( caught(Exc) ), nl, abort
;
write(status:true)
)
;
write( '! ' ), write( failure ), nl, abort
),
nl, nl, write('-----'), nl, nl,
fail.
for_real :-
write( 'All done.' ), nl.
% ex(int).
%
% Pass the salt please.
% The most basic example: pass a Prolog list of integers to an R variable
% and then back again to a Prolog variable.
%
ex(int) :-
i <- [1,2,3,4],
<- i,
I <- i,
write( i(I) ), nl.
% float.
%
% Pass a Prolog list of floats to an R variable and then back again to a Prolog variable.
%
ex(float) :-
f <- [1.0,2,3,4],
<- f,
F <- f,
write( f(F) ), nl.
% ex( float ).
%
% Pass a mixed Prolog list of integers and floats to an R variable and
% then back again to a Prolog variable.
% The returning list is occupied by floats as is the R variable.
%
ex(to_float) :-
m <- [1,2,3,4.0],
<- m,
M1 <- m,
write( m(M1) ), nl,
m <- [1,2,3,4.1],
<- m,
M2 <- m,
write( m(M2) ), nl.
% ex(bool).
%
%
ex(bool) :-
b <- [true,false,true,true],
<- print( b ),
B <- b,
write( b(B) ), nl.
% at_bool.
%
% In cases where disambiguation is needed, boolean values can be represented by @Val terms.
%
ex(at_bool) :-
b <- [@true,@false,@true,@true],
<- print( b ),
B <- b,
write( at_b(B) ), nl.
% ex(bool_f).
%
% This fails since there is a non boolean value in a list.
%
% On SWI this fails...
% On YAP this throuws exception....
%
ex(bool_f) :-
( catch(b <- [true,false,true,true,other],_,fail) ->
fail
;
true
).
% ex(bool_back).
%
% Get some boolean values back from applying a vector element equality to an integer
% vector we just passed to R. Prints the R bools first for comparison.
%
ex(bool_back) :-
t <- [1,2,3,4,5,1],
<- print(t),
s <- t==1,
<- print(s),
S <- s,
write( s(S) ), nl.
% ex(atom_char).
%
% Pass some atoms to an R vector of characters.
%
ex(atom_char) :-
f <- [a,b,c],
<- f,
F <- f,
write( f(F) ), nl.
% ex(matrix_int).
%
% Pass a 2-level list of lists of integers to an R matrix (and back again).
%
ex(matrix_int) :-
a <- [[1,2,3],[4,5,6]],
<- print(a),
A <- a,
nl, write( a(A) ), nl.
% ex(matrix_char).
%
% Pass a 2-level list of lists of characters to an R matrix (and back again).
%
ex(matrix_char) :-
a <- [[a,b,c],[d,e,f]],
<- print(a),
A <- a,
write( a(A) ), nl.
% ex(matrix_idx).
%
ex(matrix_idx) :-
a <- [[1,2,3],[4,5,6]],
<- a,
J <- a[1,_],
write( j(J) ), nl.
% ex(list).
%
% A Prolog = pairlist to an R list. Shows 2 alternative ways to access the list items.
%
ex(list) :-
a <- [x=1,y=0,z=3],
A <- a,
X0 <- a[1],
format( 'First pair of list: ~w~n', [X0] ),
X <- a[[1]],
format( 'First element of list: ~w~n', [X] ),
Y <- a$y,
format( 'Second element of list: ~w~n', [Y] ),
write( a(A) ), nl.
% ex(list).
%
% R allows for unamed lists.
%
ex(unamed) :-
li <- list(),
li[[1]] <- c(1,2,3),
<- li,
L <- li,
write( l(L) ), nl.
% ex(list_ea).
%
% Produces error due to name of constructor: -.
%
ex(list_ea) :- % produces error
catch_controlled( a <- [x=1,y=0,z-3] ),
<- a,
A <- a,
write( a(A) ), nl.
% ex(list_eb).
%
% Produces an error due to mismatch of arity of =.
%
ex(list_eb) :-
catch_controlled( a <- [x=1,y=0,=(z,3,4)] ),
<- a,
A <- a,
write( a(A) ), nl.
% ex(char_list).
%
% Pass a list which has a char value.
%
ex(char_list) :-
a <- [x=1,y=0,z="three"],
<- print(a),
A <- a,
memberchk( Z="three", A ),
write( z(Z):a(A) ), nl.
% ex(mix_list).
%
% An R-list of mixed types.
%
ex(mix_list) :-
a <- [x=1,y=[1,2,3],z=[[a,b,c],[d,e,f]],w=[true,false]],
A <- a,
<- print(a),
write( a(A) ), nl.
% ex(list2).
%
% Illustrates ways of accessing list elements.
%
ex(list2) :-
l <- list(),
l[["what"]] <- c(1,2,3),
l$who <- c(4,5,6),
<- print(l),
L <- l,
write( l(L) ), nl.
% ex(slot).
%
% Creating formal objects and accessing their content.
%
ex(slot) :-
<- setClass("track", representation(x="numeric", y="numeric")),
myTrack <- new("track", x = -4:4, y = exp(-4:4)),
<- print( myTrack@x ),
% [1] -4 -3 -2 -1 0 1 2 3 4
Y <- myTrack@y,
write( y(Y) ), nl,
<- setClass("nest", representation(z="numeric", t="track")),
myNest <- new("nest", z=c(1,2,3) ),
myNest@t <- myTrack,
myNest@t@x <- Y+1, % good ex. for hidden vars.
<- print( myNest ),
% N <- myNest, % unsupported r-type
% X <- myNest@t@x,
<- print(myNest@t@x),
X <- myNest@t@x,
<- print( myNest@t@x ),
write( x(X) ), nl.
% myTrack@x <- c(1,2,3).
% ex(add_element).
%
% Adds a third element to a list after creation.
%
ex(add_element) :-
x <- [a=1,b=2],
x$c <- [3,4],
<- print( x ), % print = $a 3
X <- x,
write( x(X) ), nl. % X = [a=3.0].
% ex(singletons).
%
% Pass an integer and a singleton number list and get them back.
% Although in R both are passed as vectors of length on, when back in Prolog
% the singleton list constructors are stripped, returing a single integer value in both cases.
%
ex(singletons) :-
s <- 3,
<- print(s),
S <- s,
<- print( s ),
t <- [3],
<- print( t ),
T <- t,
write( s(S)-t(T) ), nl.
% ex(assign).
%
% Simple assignment of an R function (+) application on 2 R values originated in Prolog.
%
ex(assign) :-
a <- 3,
<- print( a ),
b <- [2],
<- print( b ),
C <- a + b,
write( c(C) ), nl.
% ex(assign_1).
%
% Assign the result of an R operation on matrix and value to a Prolog variable.
%
ex(assign_1) :-
a <- [[1,2,3],[4,5,6]],
<- a,
B <- a*3,
write( b(B) ), nl.
% ex(assign_2).
%
% Assign the result of an R operation on matrices to a Prolog variable.
%
ex(assign_2) :-
a <- [[1,2,3],[4,5,6]],
<- print( a ),
b <- 3,
<- print( b ),
C <- a*b,
write( c(C) ), nl.
% ex(assign_r).
%
% Assign values to R variables and operate on them.
% Using c as an R variable is also a good test, as we test against c(...).
%
ex(assign_r) :-
a <- [3],
<- print( a ),
b <- [2],
<- print( b ),
c <- a + b,
<- print( c ).
/* disable for now. once Yap supports . in atoms
re-establish this, but make sure you restor
relevant flag back to its original setting. */
% ex(dot_in_function_names).
%
% Test dots in functions names via the .. mechanism.
%
ex(dot_in_function_names) :-
a <- [1.1,2,3],
<- print(a),
x <- as.integer(a),
<- print(x).
/* as above */
% ex(dot_in_rvars).
%
% Test dots in R variable names via the .. mechanism. Generates an error on the last goal.
%
ex(dot_in_rvar) :-
a.b <- [1,2,3],
<- print( a.b ),
<- print( 'a.b' ),
catch_controlled( <- print('a..b') ).
% ex(semi_column).
%
% A:B in R generates a vector of all integers from A to B.
%
ex(semi_column) :-
z <- 1:50,
<- print( z ),
Z <- z,
length( Z, Len ),
write( len(Len) ), nl.
% ex(c_vectors).
%
% r.eal also supports c() R function concatenation.
%
ex(c_vectors) :-
a <- c(1,2,3,5), % this goes via the fast route
<- print(a),
b <- c(1,1,2,2) + c(1:4),
<- print( b ),
C <- a+b,
write( 'C'(C) ), nl.
% ex(empty_args).
%
% Test calling R functions that take no arguments (via foo()).
%
ex(empty_args) :-
<- plot( 1:10, 1:10 ),
findall( I, (between(1,6,I),write('.'), flush_output, sleep(1)), _ ),
nl,
<- dev.off(). % fixme use dev.off() when Yap starts supporting it.
% ex(string).
%
% Test new (2013/11/22) string type in SWI Prolog v7.
%
ex(string) :-
( (current_predicate(string/1),string("abc")) ->
<- plot( 1:10, 1:10, main="native string type has arrived to Prolog" ),
findall( I, (between(1,6,I),write('.'), flush_output, sleep(1)), _ )
;
true
).
% ex(binary_op).
%
% Early versions of r..eal were not handling this example properly.
% Thanks to Michiel Hildebrand for spotting this.
% The correct answer is =|[0.0,4.0]|=. First subtract v1 from v2 and then take power 2.
%
ex(binary_op) :-
v1 <- c(1,1),
<- print( v1 ),
v2 <- c(1,-1),
<- print( v2 ),
P <- (v1-v2)^2,
write( P ), nl.
% not !!! : P = [0.0, 0.0].
% ex(utf).
%
% Plots 3 points with the x-axis label showing some Greek letters (alpha/Omega).
%
ex(utf) :-
<- plot( c(1,2,3), c(3,2,1), xlab= "αω" ),
findall( I, (between(1,4,I),write('.'), flush_output, sleep(1)), _ ),
nl,
<- dev.off().
% ex(utf_atom).
%
% Plots 3 points with the x-axis label showing some Greek letters (alpha/Omega) as atom preceded by +.
%
ex(utf_atom) :-
<- plot( c(1,2,3), c(3,2,1), xlab= "α/Ω" ),
findall( I, (between(1,4,I),write('.'), flush_output, sleep(1)), _ ),
nl,
<-dev.off().
% ex( utf_1 ).
%
% Thanks to Guillem R.
%
ex(utf_1) :-
s <- ['Pour ce garçon être sur une île, y avoir des histoires de cœur ambiguës et vider un fût de bière sur un canoë entouré par des caïmans, ne fut pas un mince affaire.'],
<- print( s ),
S <- s,
write( s(S) ), nl.
% ex( utf1 ).
%
% Mostly Vitor's then Sander and last one from Nicos.
%
ex(utf_2) :-
x <- [hello, 'olá', 'जैसा कहर बरपा तो बर्बाद हो जाएगी मुंबई','Beëindigen','άμπελος'],
<- x,
X <- x,
write( x(X) ), nl.
% ex(plot_cpu).
%
% Create a plot of 4 time points. Each having a push and a pull time component.
% These are the time it takes to push a list through to R and the time to Pull the same
% (very long) list back.
%
ex(plot_cpu) :-
plot_cpu( 1000 ).
ex(debug) :-
real_debug,
write( started_debugging ), nl,
x <- c(1,2,3), % c-vectors
y <- [1,2,3], % PL data lists
X <- x, % R var to PL var
x <- [a=[1,2,4],b=[4,5,6]],
A <- x,
B <- x$b, % R expression to PL var
Y <- x$b + x$a,
x$c <- [6,3,7],
real_nodebug,
write( x(X) ), nl,
write( a(A) ), nl,
write( b(B) ), nl,
write( y(Y) ), nl,
write( stopped_debugging ), nl.
% ex(rtest).
% Some tests from r_session,
%
ex(rtest) :-
<- set.seed(1), % fixme: dot
y <- rnorm(500),
<- print(y),
x <- rnorm(y),
<- print(x),
% <- x11(width=5,height=3.5),
<- plot(x,y),
r_wait,
<- dev.off(),
Y <- y,
write( y(Y) ), nl,
findall( Zx, between(1,9,Zx), Z ),
z <- Z,
<- print( z ),
cars <- [1, 3, 6, 4, 9],
% cars <- c(1, 3, 6, 4, 9),
<- print(cars),
<- pie(cars),
r_wait,
<- dev.off().
% list_times.
%
% Print some timing statistics for operations on a long list of integers.
%
list_times :-
findall( I, between(1,10000000,I), List ),
statistics( cputime, Cpu1 ), write( cpu_1(Cpu1) ), nl,
l <- List,
a <- median( l ),
statistics( cputime, Cpu2 ), write( cpu_2(Cpu2) ), nl,
b <- median( List ),
statistics( cputime, Cpu3 ), write( cpu_3(Cpu3) ), nl,
<- print(a),
<- print(b).
% adapted from YapR
% Intrinsic attributes: mode and length
tut(tut1) :-
z <- 0:9,
<- print(z),
digits <- as.character(z), % fixme: dot
<- print(digits),
d <- as.integer(digits), % fixme: dot
<- print(d).
% changing the length of an object
tut(tut2) :-
e <- numeric(),
(e[3]) <- 17,
<- print(e),
alpha <- 1:10,
alpha <- alpha[2 * 1:5],
<- alpha, % = 2, 4, 6, 8 10
length(alpha) <- 3,
<- print(alpha), % = 2, 4, 6
nl, write( ' on beta now ' ), nl, nl,
beta <- 1:10,
beta <- 2 * beta,
<- print(beta), % 2 4 6 8 10 12 14 16 18 2
length(beta) <- 3,
<- print(beta). % 2 4 6
% Getting and setting attributes
tut(tut3) :-
z <- 1:100,
attr(z, "dim") <- c(10,10),
<- print( z ).
% factors and tapply.
tut(tut4) :-
/* state <- c("tas", "sa", "qld", "nsw", "nsw", "nt", "wa", "wa",
"qld", "vic", "nsw", "vic", "qld", "qld", "sa", "tas",
"sa", "nt", "wa", "vic", "qld", "nsw", "nsw", "wa",
"sa", "act", "nsw", "vic", "vic", "act"), */
state <- [tas,sa,qld,nsw,nsw,nt,wa,wa,qld,vic,nsw,vic,qld,qld,sa,tas,sa,nt,wa,vic,qld,nsw,nsw,wa,sa,act,nsw,vic,vic,act],
<- print( state ),
% <- astate,
statef <- factor(state),
<- print( statef ),
<- levels(statef),
incomes <- c(60, 49, 40, 61, 64, 60, 59, 54, 62, 69, 70, 42, 56,
61, 61, 61, 58, 51, 48, 65, 49, 49, 41, 48, 52, 46,
59, 46, 58, 43),
incmeans <- tapply(incomes, statef, mean),
% notice the function definition.
stderr <- ( function(x) -> sqrt(var(x)/length(x)) ),
% <- print( stderr ),
X <- stderr( [1,2,3,4,5,6,7,8,9,10] ),
writeln(stderr=X),
incster <- tapply(incomes, statef, stderr),
<- print( incster ).
tut(tut5) :-
z <- 1:1500,
dim(z) <- c(3,5,100),
a <- 1:24,
dim(a) <- c(3,4,2),
<- print(a[2,_,_]),
<- print(dim(a)),
x <- array(1:20, dim=c(4,5)),
<- print( x ),
i <- array(c(1:3,3:1), dim=c(3,2)),
<- print( i ),
x[i] <- 0,
<- print( x ),
h <- 1:10,
z <- array(h, dim=c(3,4,2)),
<- print( z ),
a <- array(0, dim=c(3,4,2)),
<- print( a ),
% ab <- z '%o%' a,
ab <- z+a, % z @^@ a,
<- ab,
f <- ( function(xx, yy) -> cos(yy)/(1 + xx^2) ),
w <- outer(z, a, f),
<- w.
tut(tut6) :-
d <- outer(0:9, 0:9),
fr <- table(outer(d, d, "-")),
<- plot(as.numeric(names(fr)), fr, type="h", xlab="Determinant", ylab="Frequency"), % fixme: dot
format( '~n type :- "dev.off()." to close the plot display.~n', []).
tut(tut7) :-
m <- function(x) -> [ array(a), (a[x]<- x), while((x > 0), [x <-x-1, a[x] <- a[x+1]+x]), a[0] ],
m(100),
X <- a,
writeln(X).
% auxiliary,
cpu_points( [], [], [] ).
cpu_points( [H|T], [S|Ss], [L|Ls] ) :-
between_1_and(H,Long),
statistics( cputime, _) ,
length( Long, Lengtho ), write( leno(Lengtho) ), nl,
statistics( cputime, S0 ),
( number(S0) -> S0 = S ; S0 = [_,S] ),
% statistics( cputime, [_,S] ),
long <- Long,
Back <- long,
Back = [Hb|_],
Hb =:= 1,
statistics( cputime, L0 ),
( number(L0) -> L0 = L ; L0 = [_,L] ),
% statistics( cputime, [_,L] ),
length( Back, BackLen ),
write( back_len(BackLen) ), nl,
% L = 0,
cpu_points( T, Ss, Ls ) .
% auxiliaries,
catch_controlled( Expr ) :-
catch( Expr, Caught, true ),
( \+ var(Caught) -> write( caught_controlled(Caught) ), nl; fail ).
between_1_and(N,X) :-
( var(N) -> N is 100; true ),
IntN is integer(N),
findall( I, between(1,IntN,I), Is ),
i <- Is,
X <- i.
cpu( R ) :-
( var(R) -> R is 10000; true ),
findall( F, between_1_and(R,F), Fs ),
f <- Fs,
statistics( cputime, Cpu1 ),
write( cputime_to_push(Cpu1) ), nl,
X <- f, % when F <- f the predicate fails midway for large Len !!!
statistics( cputime, Cpu2 ),
write( cputime_to_pull(Cpu2) ), nl,
length( X, Len ),
write( len(Len) ), nl.
plot_cpu( Factor ) :-
nl,
( Factor > 10 ->
M='if your set-up fails on this test increase the size of stack.',
write( M ), nl, nl
;
true
),
points <- [10,100,500,1000],
points <- as.integer( points * Factor ), % fixme: dot
<- points,
Points <- points,
write( points(Points) ), nl,
cpu_points( Points, Push, Pull ),
push <- Push,
pull <- Pull,
write( plotting(Pull,Push) ), nl,
<- plot( points, pull, ylab = "pull & push (red) - in seconds" ),
<- points( points, push, col="red" ).