Customer section

Forum index » pdScript » pdScript/newLISP demo Tower of Hanoi

HPW

Number of posts: 203
Rank: User

Profile of user
Response

Posted: 27.08.2011 [16:52]

Hello,

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

newLispHanoi.dpas

Code:

program Script1;

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 newLispEvalStr(paramstr: PChar): PChar; external 'newlispEvalStr@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 pdImageFillRect( X1,Y1,X2,Y2,bgcolor : PChar ) : BOOLEAN;
VAR
rect1 : TRect;
BEGIN
Result := FALSE;
TRY
Image1.Canvas.Brush.Color := GetColor(bgcolor);
rect1.left := StrToInt(X1);
rect1.top := StrToInt(Y1);
rect1.right := StrToInt(X2)+1;
rect1.bottom := StrToInt(Y2)+1;
// Image1.Canvas.FillRect(Rect(StrToInt(X1),StrToInt(Y1),StrToInt(X2)+1,StrToInt(Y2)+1));
Image1.Canvas.FillRect(rect1);
Result := TRUE;
EXCEPT
showmessage('Error');
END;
END;

FUNCTION pdImageRectangle(X1,Y1,X2,Y2,lcolor,bgcolor : PChar ) : BOOLEAN;
VAR
rect1 : TRect;
BEGIN
Result := FALSE;
TRY
Image1.Canvas.Brush.Color := GetColor(bgcolor);
Image1.Canvas.Pen.Color := GetColor(lcolor);
rect1.left := StrToInt(X1);
rect1.top := StrToInt(Y1);
rect1.right := StrToInt(X2)+1;
rect1.bottom := StrToInt(Y2)+1;
// Rect is missing
// Image1.Canvas.Rectangle(Rect(StrToInt(X1),StrToInt(Y1),StrToInt(X2)+1,StrToInt(Y2)+1));
Image1.Canvas.Rectangle(StrToInt(X1),StrToInt(Y1),StrToInt(X2)+1,StrToInt(Y2)+1);
Result := TRUE;
EXCEPT
showmessage('Error');
END;
END;

FUNCTION pdImageDrawLine( X1,Y1,X2,Y2,pencolor,bgcolor,pstyle : PChar ) : BOOLEAN;
BEGIN
Result := FALSE;
TRY
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;

Image1.Canvas.MoveTo(StrToInt(X1),StrToInt(Y1));
Image1.Canvas.LineTo(StrToInt(X2),StrToInt(Y2));
Image1.Canvas.Pixels[StrToInt(X2),StrToInt(Y2)] := Image1.Canvas.Pen.Color;

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
pdImageDrawLine('100','100','200','200','clBlack','clwhite','psSolid');
end;

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

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

procedure Button1_OnClick(Sender: TObject);
begin
pdImageFillRect('150','150','250','250','clRed');
end;

procedure Button5_OnClick(Sender: TObject);
begin
pdImageRectangle('250','250','270','270','clRed','clWhite');
end;

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

begin
AssignEvents;
// Image1.Canvas.LineTo(50,50);
pdImageTextOut('newLispHanoiDemo','30','10','Arial','12','clWhite','clRed');
RegisterNewLispCommand('pdImageRefresh',0);
RegisterNewLispCommand('pdImageFillRect',5);
RegisterNewLispCommand('pdImageRectangle',6);
RegisterNewLispCommand('pdImageDrawLine',7);
RegisterNewLispCommand('pdImageTextOut',7);
end.



newLispHanoi.dfm

Code:

object PSForm: TPSForm
Left = 279
Top = 90
BorderIcons = [biSystemMenu, biMinimize]
BorderStyle = bsSingle
Caption = 'newLispHanoi'
ClientHeight = 345
ClientWidth = 514
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 = 505
Height = 310
end
object Button2: TButton
Left = 8
Top = 320
Width = 61
Height = 21
Caption = 'DrawLine'
TabOrder = 0
end
object Button3: TButton
Left = 72
Top = 320
Width = 61
Height = 21
Caption = 'DrawText'
TabOrder = 1
end
object Button4: TButton
Left = 416
Top = 320
Width = 93
Height = 21
Caption = 'newLispHanoi'
TabOrder = 2
end
object Button1: TButton
Left = 136
Top = 320
Width = 61
Height = 21
Caption = 'FillRect'
TabOrder = 3
end
object Button5: TButton
Left = 200
Top = 320
Width = 61
Height = 21
Caption = 'Rectangle'
TabOrder = 4
end
object Edit1: TEdit
Left = 320
Top = 320
Width = 45
Height = 21
Hint = 'Number of poles'
ParentShowHint = False
ShowHint = True
TabOrder = 5
Text = '5'
end
object Edit2: TEdit
Left = 368
Top = 320
Width = 45
Height = 21
Hint = 'Delay in ms'
ParentShowHint = False
ShowHint = True
TabOrder = 6
Text = '1'
end
end



newLispHanoi.lsp

Code:

;; newLispHanoi.lsp - graphics demo for newLISP-pdScript
;;
;; to run: (Hanoi:run 6 1)
;;
;;
;; Modified from Hanoi.lsp from newLSIP distribution
;; Ported to pdScript
;; Hans-Peter Wickern
;; 27.08.2011

(context 'Hanoi)

(define (delete-disk n item itemlst polex polex1)
(if (set 'item(find (assoc n disklst)disklst))
(begin
(set 'itemlst (pop disklst item)
'polex (-(+(nth 1 itemlst)(/(-(nth 3 itemlst)(nth 1 itemlst))2))5)
'polex1 (+(+(nth 1 itemlst)(/(-(nth 3 itemlst)(nth 1 itemlst))2))5)
)
(if (=(nth 2 itemlst)70)
(begin
(MAIN:pdImageRectangle MAIN:pdScriptInstanceAddr "pdImageRectangle" (string(nth 1 itemlst)) (string(nth 2 itemlst)) (string(nth 3 itemlst)) (string(nth 4 itemlst)) "clWhite" "clWhite")
(MAIN:pdImageRefresh MAIN:pdScriptInstanceAddr "pdImageRefresh")
(if (> dtime 0)
(sleep dtime)
)
)
(begin
(MAIN:pdImageRectangle MAIN:pdScriptInstanceAddr "pdImageRectangle" (string(nth 1 itemlst)) (string(nth 2 itemlst)) (string(nth 3 itemlst)) (string(-(nth 4 itemlst)1)) "clWhite" "clWhite")
(MAIN:pdImageDrawLine MAIN:pdScriptInstanceAddr "pdImageDrawLine" (string polex) (string(nth 2 itemlst)) (string polex) (string(nth 4 itemlst)) "clNavy" "" "")
(MAIN:pdImageFillRect MAIN:pdScriptInstanceAddr "pdImageFillRect" (string(+ polex 1)) (string(nth 2 itemlst)) (string(- polex1 1)) (string(nth 4 itemlst)) "clLime")
(MAIN:pdImageDrawLine MAIN:pdScriptInstanceAddr "pdImageDrawLine" (string polex1) (string(nth 2 itemlst)) (string polex1) (string(nth 4 itemlst)) "clNavy" "" "")
(MAIN:pdImageRefresh MAIN:pdScriptInstanceAddr "pdImageRefresh")
(if (> dtime 0)
(sleep dtime)
)
)
)
)
)
)

(define (hanoi-prep )
(MAIN:pdImageRectangle MAIN:pdScriptInstanceAddr "pdImageRectangle" "0" "30" "500" "300" "clWhite" "clWhite")
(MAIN:pdImageTextOut MAIN:pdScriptInstanceAddr "pdImageTextOut" "Towers Of Hanoi" "160" "30" "Times" "18" "clWhite" "clNavy")
(MAIN:pdImageRefresh MAIN:pdScriptInstanceAddr "pdImageRefresh")
)

(define (make-disk disk pole height , x x1 y y1 width)
(set 'x
(case pole
(pole1 115)
(pole2 235)
(pole3 355)))
(set 'width (+ 20 (* 10 disk))
'x (- x (/ width 2))
'y (- 250 (* 10 height))
'x1 (+ x width)
'y1 (+ y 10)
)
(set 'disklst (append disklst (list(list disk x y x1 y1))))
(MAIN:pdImageRectangle MAIN:pdScriptInstanceAddr "pdImageRectangle" (string x) (string y) (string x1) (string y1) "clNavy" "clRed")
(MAIN:pdImageRefresh MAIN:pdScriptInstanceAddr "pdImageRefresh")
(if (> dtime 0)
(sleep dtime)
)
)

(define (move n from to with)
(if (> n 0)
(begin
(move (- n 1) from with to)
(pull-disk n from)
(move-disk-over n from to)
(push-disk n to)
(move (- n 1) with to from)
)
)
)

(define (move-disk-over n from to)
(delete-disk n)
(make-disk n to 18)
)

(set 'pole1 '()
'pole2 '()
'pole3 '(1 2 3 4 5)
)

(define (pull-disk n pole)
(pop (eval pole))
(delete-disk n)
(make-disk n pole 18)
)

(define (push-disk n pole)
(push n (eval pole))
(delete-disk n)
(make-disk n pole (length (eval pole)))
)

(define (run n ti)
(set 'disklst '()
'dtime ti
'starttime (time-of-day))
(hanoi-prep)
(if (> n 10)
(set 'n 10))
(setup-poles n)
(move n 'pole1 'pole3 'pole2)
(set 'endtime (time-of-day))
)

(define (setup-poles n)
(set 'pole1 (set 'pole2 (set 'pole3 '())))
(MAIN:pdImageRectangle MAIN:pdScriptInstanceAddr "pdImageRectangle" "50" "250" "440" "260" "clNavy" "clLime")
(MAIN:pdImageRectangle MAIN:pdScriptInstanceAddr "pdImageRectangle" "110" "90" "120" "250" "clNavy" "clLime")
(MAIN:pdImageRectangle MAIN:pdScriptInstanceAddr "pdImageRectangle" "230" "90" "240" "250" "clNavy" "clLime")
(MAIN:pdImageRectangle MAIN:pdScriptInstanceAddr "pdImageRectangle" "350" "90" "360" "250" "clNavy" "clLime")
(MAIN:pdImageRefresh MAIN:pdScriptInstanceAddr "pdImageRefresh")
(while (> n 0)
(push n pole1)
(make-disk n 'pole1 (length pole1))
(MAIN:pdImageRefresh MAIN:pdScriptInstanceAddr "pdImageRefresh")
(dec n)
)
)

(context 'MAIN)
;EOF


HPW

Number of posts: 203
Rank: User

Profile of user
Response

Posted: 27.08.2011 [22:40]

Hello,

I edited the above dpas and removed function IsNumberPair. Was not used.

Hans-Peter

admin

Number of posts: 554
Rank: admin •••

Profile of user
Response

Posted: 05.09.2011 [00:36]

Hi.

Thank you very much - nice project!

This demo is included in the last beta distribution and it is fully functional.

Best regards,

Roman

HPW

Number of posts: 203
Rank: User

Profile of user
Response

Posted: 21.09.2011 [22:53]

Hello,

I updated the above dpas with using newlispCallback from newlisp 10.3.3

Hans-Peter

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