Customer section

Forum index » pdScript » pdScript/newLISP demo with Turtle graphics/Dragon Fractal

HPW

Number of posts: 203
Rank: User

Profile of user
Response

Posted: 25.08.2011 [12:49]

A first demo using the callback functions for real graphics.
(Store all files in the same folder)
(Work with latest dev-Snapshot)

newLispTurtle.dpas

Code:

program newLispTurtle;

TYPE
CharSet = Set of AnsiChar;

FUNCTION StrIsInteger(const S: AnsiString): Boolean;
var
testint : integer;
begin
testint := StrToInt (s);
If testint > -1 Then
Result := True
else
Result := False;
end;

FUNCTION IsNumberPair(numb1, numb2 : String) : BOOLEAN;
BEGIN
If StrIsInteger(numb1) AND StrIsInteger(numb2) THEN
Result := True
Else
Result := False;
END;

function newLispEvalStr(paramstr: PChar): PChar; external 'newlispEvalStr@newlisp.dll stdcall';
//function newLispEvalStr(paramstr: PChar): PChar; external 'newlispEvalStr@c:\Programme\newlisp\newlisp.dll stdcall';
function newlispCallback(callbackname: PChar; callbackaddress: Integer; calltype: PChar): PChar; external 'newlispCallback@newlisp.dll stdcall';

FUNCTION GetColor( colorstring :STRING ) : TColor;
VAR
rvar : String;
gvar : String;
bvar : String;
rest : String;
tmpstring : STRING;
BEGIN
If colorstring = '' Then
Result := clWhite
ELSE
BEGIN
IF colorstring = 'clMoneyGreen' THEN
colorstring := '$00C0DCC0';
IF colorstring = 'clSkyBlue' THEN
colorstring := '$00F0CAA6';
IF colorstring = 'clCream' THEN
colorstring := '$00F0FBFF';
IF colorstring = 'clMedGray' THEN
colorstring := '$00A4A0A0';

IF colorstring[1] = '#' THEN
BEGIN
while Pos('#', colorstring) <> 0 do
Delete(colorstring, Pos('#', colorstring), 1);
colorstring := (Copy(colorstring,5,2) + Copy(colorstring,3,2) + Copy(colorstring,1,2));
Result := StrToInt('$' + colorstring);
END
ELSE IF (colorstring[1] = '0') AND (colorstring[2] = 'x') AND (length(colorstring) = 8) THEN
BEGIN
colorstring := (Copy(colorstring,7,2) + Copy(colorstring,5,2) + Copy(colorstring,3,2));
Result := StrToInt('$' + colorstring);
END
ELSE IF (colorstring[1] = 'R') AND (colorstring[2] = 'G') AND (colorstring[3] = 'B') AND (colorstring[4] = 'I') AND (colorstring[5] = 'N') AND (colorstring[6] = 'T') THEN
BEGIN
colorstring := Copy(colorstring,7,length(colorstring)-6);
tmpstring := IntToHex(StrToInt(colorstring),6);
tmpstring := IntToStr(StrToInt('$' + Copy(tmpstring,5,2) + Copy(tmpstring,3,2) + Copy(tmpstring,1,2)));
Result := TColor(StrToInt(tmpstring));
END
ELSE If StrIsInteger(colorstring) Then
BEGIN
Result := TColor(StrToInt(colorstring));
END
ELSE IF POS(',',colorstring) > 0 THEN
BEGIN
rvar := Copy(colorstring,1,POS(',',colorstring)-1);
rest := Copy(colorstring,POS(',',colorstring)+1,length(colorstring)-POS(',',colorstring));
gvar := Copy(rest,1,POS(',',rest)-1);
bvar := Copy(rest,POS(',',rest)+1,length(rest)-POS(',',rest));
{ showmessage(rvar+'/'+gvar+'/'+bvar);}
Result := rgb(StrToInt(rvar),StrToInt(gvar),StrToInt(bvar));
END
ELSE
Result := StringToColor(colorstring);
END;
END;

FUNCTION RegisterNewLispCommand(funcname : STRING; NumbOfParams : Integer ) : BOOLEAN;
var
newlispstr : string;
begin
// I'm using Lutz code to link Pascal function to be used in newLisp.
// newlispstr := '(set '''+funcname+' print)' +
// '(cpymem (pack "ld" 265) (first (dump '+funcname+')) 4)' +
// '(cpymem (pack "ld" ' +
// IntToStr(GetPDScriptCallbackAddrAsInt(NumbOfParams)) + ') (+ (first (dump '+funcname+')) 12) 4)' +
// '(cpymem (pack "ld" "'+funcname+'") (+ (first (dump '+funcname+')) 8) 4)';
// newLispEvalStr(pchar(newlispstr));

// This one-liner for newlisp 10.3.3 replaces the above code
newlispCallback(funcname,GetPDScriptCallbackAddrAsInt(NumbOfParams),'');

newlispstr := '(setq pdScriptInstanceAddr '+ IntToStr((GetPDScriptInstanceAddrAsInt))+')';
newLispEvalStr(pchar(newlispstr));
end;

FUNCTION pdImageRefresh : BOOLEAN;
BEGIN
Result := FALSE;
TRY
Image1.Repaint;
EXCEPT
showmessage('Error');
END;
END;

FUNCTION pdImageDrawLines( pointlist,pdelim,pencolor,bgcolor,pstyle : PChar ) : BOOLEAN;
VAR P : PCHAR;
TempList : TStrings;
argstr : STRING;
ext : STRING;
pcount : Integer;
BEGIN
Result := FALSE;
TRY
TempList := TStringList.Create;
try
ext := ExtractFileExt(pointlist);
{ showmessage(ext);}
IF ext <> '' THEN
BEGIN
IF FileExists(pointlist) THEN
BEGIN
TempList.LoadFromFile(pointlist);
END
ELSE
BEGIN
argstr := StrReplace(pointlist,pdelim,chr(13)+chr(10),true,true);
TempList.Text := argstr;
END;
END
ELSE
BEGIN
argstr := StrReplace (pointlist,pdelim,chr(13)+chr(10),true,true);
TempList.Text := argstr;
END;
FINALLY
END;
{ showmessage(TempList.Text);}

Image1.Canvas.Pen.Color := GetColor(pencolor);

IF String(bgcolor) <> '' THEN
Image1.Canvas.Brush.Color := GetColor(bgcolor);

IF AnsiUpperCase(pstyle) = 'PSDASH' THEN
Image1.Canvas.Pen.Style := psDash
ELSE IF AnsiUpperCase(pstyle) = 'PSDOT' THEN
Image1.Canvas.Pen.Style := psDot
ELSE IF AnsiUpperCase(pstyle) = 'PSDASHDOT' THEN
Image1.Canvas.Pen.Style := psDashDot
ELSE IF AnsiUpperCase(pstyle) = 'PSDASHDOTDOT' THEN
Image1.Canvas.Pen.Style := psDashDotDot
ELSE
Image1.Canvas.Pen.Style := psSolid;

IF IsNumberPair(TempList[0],TempList[1]) THEN
Image1.Canvas.MoveTo(StrToInt(TempList[0]),StrToInt(TempList[1]));
pcount := 2;
while (pcount <= TempList.Count - 1) do
begin
IF IsNumberPair(TempList[pcount],TempList[pcount+1]) THEN
BEGIN
Image1.Canvas.LineTo(StrToInt(TempList[pcount]),StrToInt(TempList[pcount+1]));
Image1.Canvas.Pixels[StrToInt(TempList[pcount]),StrToInt(TempList[pcount+1])] := Image1.Canvas.Pen.Color;
END;
// INC(pcount, 2);
INC(pcount);
INC(pcount);
END;
TempList.Free;
Image1.Canvas.Pen.Style := psSolid;
Result := TRUE;
EXCEPT
showmessage('Error');
END;
END;

FUNCTION pdImageTextOut( tstring,X1,Y1,fontname,size,bgcolor,lcolor : PChar ) : BOOLEAN;
BEGIN
Result := FALSE;
TRY
// Showmessage('In TextOut');
Image1.Canvas.Brush.Color := GetColor(bgcolor);
Image1.Canvas.Font.Color := GetColor(lcolor);
Image1.Canvas.Font.Name := fontname;
Image1.Canvas.Font.Size := StrToInt(size);
Image1.Canvas.TextOut(StrToInt(X1),StrToInt(Y1),tstring);
Result := TRUE;
EXCEPT
showmessage('Error');
END;
END;

procedure Button2_OnClick(Sender: TObject);
begin
pdImageDrawLines('50;50;100;100',';','clBlack','clwhite','');
end;

procedure Button3_OnClick(Sender: TObject);
begin
pdImageTextOut('Test','50','300','Arial','12','clWhite','clRed');
end;

procedure Button4_OnClick(Sender: TObject);
Var
lispsourcepath : String;
newlispstr : String;
retstr : String;
begin
lispsourcepath := ExtractFilePath(ParamStr(0));
lispsourcepath := lispsourcepath+'newLispTurtle.lsp';
lispsourcepath := StrReplace(lispsourcepath,'\','/',true,true);
// Showmessage(lispsourcepath);
newlispstr := '(load "'+ lispsourcepath +'")';
// Showmessage(newlispstr);
retstr := newLispEvalStr (pchar(newlispstr));
// Showmessage(retstr);
newlispstr := '(Turtle:run)';
// Showmessage(newlispstr);
retstr := newLispEvalStr (pchar(newlispstr));
// Showmessage(retstr);
end;

procedure AssignEvents;
begin
Button2.OnClick := @Button2_OnClick;
Button3.OnClick := @Button3_OnClick;
Button4.OnClick := @Button4_OnClick;
end;

begin
AssignEvents;
// Image1.Canvas.LineTo(50,50);
pdImageTextOut('newLispTurtleDemo','30','20','Arial','12','clWhite','clRed');
RegisterNewLispCommand('pdImageRefresh',0);
RegisterNewLispCommand('pdImageDrawLines',5);
RegisterNewLispCommand('pdImageTextOut',7);
end.



newLispTurtle.dfm

Code:

object PSForm: TPSForm
Left = 276
Top = 90
BorderIcons = [biSystemMenu, biMinimize]
BorderStyle = bsSingle
Caption = 'newLispTurtle'
ClientHeight = 433
ClientWidth = 510
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'Tahoma'
Font.Style = []
OldCreateOrder = False
Position = poDesigned
PixelsPerInch = 96
TextHeight = 13
object Image1: TImage
Left = 4
Top = 4
Width = 500
Height = 400
end
object Button2: TButton
Left = 4
Top = 408
Width = 93
Height = 21
Caption = 'DrawLine'
TabOrder = 0
end
object Button3: TButton
Left = 100
Top = 408
Width = 93
Height = 21
Caption = 'DrawText'
TabOrder = 1
end
object Button4: TButton
Left = 412
Top = 408
Width = 93
Height = 21
Caption = 'newLispTurtle'
TabOrder = 2
end
end



newLispTurtle.lsp

Code:

;; newLispTurtle.lsp - graphics demo for newLISP-pdScript
;;
;; to run: (run)
;;
;; Modified from Turtle.lsp from old newLISP-tk distribution
;; Ported to pdScript
;; Hans-Peter Wickern
;; 25.08.2011 07:43:39

(context 'Turtle)

(set-locale "C")

(set 'color "blue")

(set 'direction -425.6857918)

(define (dragon sign level)
(if (= 0 level)
(turtle-forward 4)
(begin
(dec level) ;Remove quote for newLISP 10 (9.9.92)
(turtle-right (sign 45))
(dragon - level)
(turtle-left (sign 90))
(dragon + level)
(turtle-right (sign 45)))))

(define (dragon-curve n clr)
(set 'color clr)
(dragon + n))

(define (draw )
(MAIN:pdImageDrawLines MAIN:pdScriptInstanceAddr "pdImageDrawLines" (string(join(map tround points)"|")) "|" (string color) "" "")
(MAIN:pdImageRefresh MAIN:pdScriptInstanceAddr "pdImageRefresh")
(set 'points (list newX newY)))

(define (tround rnumb)
(if (>=(sub rnumb (floor rnumb))0.5)
(string(ceil rnumb))
(string(floor rnumb))
))

(define (draw-rect n)
(turtle-forward n)
(turtle-right 90)
(turtle-forward n)
(turtle-right 90)
(turtle-forward n)
(turtle-right 90)
(turtle-forward n))

(define (draw-squirl n)
(dotimes (x (/ n 3))
(turtle 'forward n)
(turtle 'right 90)
(set 'n (- n 2)))
(turtle-go-to 0 0))

(set 'lastX 120)

(set 'lastY 200)

(set 'newX 120)

(set 'newY 200)

(define (rose clr)
(set 'color clr)
(dotimes (x 90)
(draw-rect 60)
(turtle-right 2)))

(define (run )
(MAIN:pdImageTextOut MAIN:pdScriptInstanceAddr "pdImageTextOut" "Dragon Fractal" "380" "70" "Times" "12" "clWhite" "clNavy")
(MAIN:pdImageTextOut MAIN:pdScriptInstanceAddr "pdImageTextOut" "Turtle Graphics" "100" "350" "Times" "16" "clWhite" "clNavy")
(MAIN:pdImageRefresh MAIN:pdScriptInstanceAddr "pdImageRefresh")
(turtle-start 300 50)
(dragon-curve 12 "clRed")
(draw)
(turtle-start 120 200)
(rose "clBlue")
"Ready"
)

(define (turtle-center )
(set 'lastX 150
'lastY 60
'newX 150
'newY 60
'direction 1.570796327))

(define (turtle-forward d)
(set 'newX (add lastX (mul (cos direction) d))
'newY (add lastY (mul (sin direction) d)))
(push newX points -1)
(push newY points -1)
(if (= (length points) 100)
(draw))
(set 'lastX newX
'lastY newY))

(define (turtle-go-to x y)
(set 'lastX x
'lastY y))

(define (turtle-left d)
(set 'direction (add direction (mul d 0.017453292))))

(define (turtle-right d)
(set 'direction (sub direction (mul d 0.017453292))))

(define (turtle-start x y)
(set 'lastX x
'lastY y
'newX x
'newY y
'points (list x y)
'direction 1.570796327))

(set 'x 0)

(context 'MAIN)


HPW

Number of posts: 203
Rank: User

Profile of user
Response

Posted: 26.08.2011 [07:35]

Hello,

I updated the above code so that newlisp use its context function to isolate the modul from MAIN context.

MAIN:pdImange... should read MAIN: pdImange... without the space.

PS: When it is a problem to get the formated source from the forum I can send a zip


Hans-Peter

HPW

Number of posts: 203
Rank: User

Profile of user
Response

Posted: 27.08.2011 [15:42]

Hello,

I updated the above dpas again with a new generic function RegisterNewLispCommand.

Code:

FUNCTION RegisterNewLispCommand(funcname : STRING; NumbOfParams : Integer ) : BOOLEAN;
var
newlispstr : string;
begin
// I'm using Lutz code to link Pascal function to be used in newLisp.
newlispstr := '(set '''+funcname+' print)' +
'(cpymem (pack "ld" 265) (first (dump '+funcname+')) 4)' +
'(cpymem (pack "ld" ' +
IntToStr(GetPDScriptCallbackAddrAsInt(NumbOfParams)) + ') (+ (first (dump '+funcname+')) 12) 4)' +
'(cpymem (pack "ld" "'+funcname+'") (+ (first (dump '+funcname+')) 8) 4)';
newLispEvalStr(pchar(newlispstr));
newlispstr := '(setq pdScriptInstanceAddr '+ IntToStr((GetPDScriptInstanceAddrAsInt))+')';
newLispEvalStr(pchar(newlispstr));
end;

//RegisterNewLispCommand('pdImageDrawLines',5);



Makes the demo shorter and it will be usefull in bigger demos.

Hans-Peter

admin

Number of posts: 554
Rank: admin •••

Profile of user
Response

Posted: 05.09.2011 [00:40]

Hi,

this demo is not functional for me. Testing methods are ok, but the main Turtle demo is not.
Can you test it with the latest beta of pdScript (v1.6.1.3b) ?

Thanks,

Roman

HPW

Number of posts: 203
Rank: User

Profile of user
Response

Posted: 05.09.2011 [12:22]

Hello,

The demo works for me with the current beta.
Anyway I updated the dpas and the lsp posted above with a pdImageRefresh function like in the hanoi demo.
Then you should see even the draw progress.

When I rename my newlisp.dll like in this example the compile failed with a fatal error:

function newLispEvalStr(paramstr: PChar): PChar; external 'newlispEvalStr@newlispwrong.dll stdcall';

The IDE does not show that line as the error.
Can I check in code if a function definition fails?


Hans-Peter

admin

Number of posts: 554
Rank: admin •••

Profile of user
Response

Posted: 05.09.2011 [12:31]

Hi!

Thanks - now it is ok. Probably, It was already correct before, but I didn't see the draw progress, so I thought there is an error.

The compilation of script with an external DLL imports does not return a meaningful error from RemObjects engine.
Well, I will need to add some new code directly to this engine.

I am also thinking about some conditional directives, that could be preprocessed before the compilation (something like {$I} directive), where the developer can write its own code to copy needed files from known location near to the pdScript.exe, or to the system, etc.

Roman

HPW

Number of posts: 203
Rank: User

Profile of user
Response

Posted: 21.09.2011 [22:51]

Hello,

I updated the above dpas with using newlispCallback from newlisp 10.3.3

Hans-Peter

HPW

Number of posts: 203
Rank: User

Profile of user
Response

Posted: 03.10.2011 [11:41]

Hello,

I updated the above newLispTurtle.lsp with line

Code:
 
(set-locale "C")



Otherwise the script does not run on my system because decimale is set to ','

Not sure if this is related to the latest pdScript release.


Hans-Peter

admin

Number of posts: 554
Rank: admin •••

Profile of user
Response

Posted: 03.10.2011 [13:01]

Hello!

As I answered in other topic, there are no changes of regional settings in pdScript setup wizard, nor in the pdScript/pdScript IDE application itself. So maybe you can ask the newLisp guys.

Roman

HPW

Number of posts: 203
Rank: User

Profile of user
Response

Posted: 03.10.2011 [18:51]

Hello,

Lutz explained the reason. The contained Dll was the UTF-version, which get the locale from the OS.
The ANSI-Versionis set to C-setting.
So add the fix to the lsp-source and it will always work.

Hans-Peter

admin

Number of posts: 554
Rank: admin •••

Profile of user
Response

Posted: 03.10.2011 [19:02]

Thank you :-)

New post to this topic

[.bold.]TEXT[./bold.]  [.italic.]TEXT[./italic.]  [.code.] TEXT [./code.]  [.quote.] TEXT [./quote.]

Number of topics: 370 • Number of posts: 1236 • Number of registered users: 59

Copyright © 2008-2019  Precision software & consulting. All rights reserved.
Send your comments to www pages.
Contact   |   RSS
Precision software & consulting
Narodnich mucedniku 447
738 01  Frydek-Mistek
Czech Republic