procedure AdvanceRoi; begin hloc:=hloc+RoiWidth; if (hloc+RoiWidth div 2)>PicWidth then begin hloc:=0; vloc:=vloc+RoiHeight; end; if (hloc+RoiWidth)>PicWidth then hloc:=PicWidth-RoiWidth; if (vloc+RoiHeight)>PicHeight then vloc:=PicHeight-RoiHeight; MakeRoi(hloc,vloc,RoiWidth,RoiHeight); end; procedure MakeBlocks(n:integer); var i,hloc,vloc,PicWidth,PicHeight:integer; RoiWidth,RoiHeight:integer; scale:real; begin GetPicSize(PicWidth,PicHeight); scale:=1/n; SelectAll; SetScaling('Nearest Neighbor; Same Window'); ScaleAndRotate(scale,scale,0); RestoreRoi; GetRoi(hloc,vloc,RoiWidth,RoiHeight); copy; SelectAll; Clear; hloc:=0; vloc:=0; MakeRoi(hloc,vloc,RoiWidth,RoiHeight); for i:=1 to n*n do begin Paste; AdvanceRoi; end; KillRoi; end; procedure DoTextDemo; begin RevertToSaved; MoveTo(100,20); SetForegroundColor(255); SetBackgroundColor(0); SetFont('Geneva'); SetFontSize(24); SetText('No background, Bold, Center'); Writeln('Text'); SetText('With background'); Writeln('With Background'); SetText('Bold'); Writeln('Bold'); SetText('Underlined'); Writeln('Underlined'); SetText('Italic'); Writeln('Italics'); SetText('Outline'); Writeln('Outlined'); SetText('Shadow'); Writeln('Shadowed'); SetText('Plain'); SetFontSize(9); MoveTo(100,240); Writeln('Very small'); wait(.5); SetFontSize(24); MoveTo(100,240); Writeln('Small'); wait(.5); SetFontSize(48); MoveTo(100,240); SetText('Bold'); Writeln('MEDIAN'); wait(.5); SetFontSize(96); MoveTo(100,240); Writeln('LARGE'); wait(1); end; procedure DrawGrayLevelScale(nBoxes:integer); var PicWidth, PicHeight,i,GrayLevel,hloc,vloc,width,height,vdelta:integer; begin GetPicSize(PicWidth,PicHeight); SetFont('Helvetica'); SetFontSize(9); SetText('Bold; Center; with background'); SetBackgroundColor(0); width:=0.9*PicHeight/nBoxes; height:=width; hloc:=0.05*PicHeight; vloc:=hloc; vdelta:=height-1; GrayLevel:=0; for i:=1 to nBoxes do begin MakeRoi(hloc,vloc,width,height); SetForeground(GrayLevel); Fill; SetForeground(255); DrawBoundary; MoveTo(hloc+width/2,vloc+height/2); Writeln(GrayLevel); GrayLevel:=GrayLevel+trunc(256/nBoxes); vloc:=vloc+vdelta; end; end; procedure DrawColorScale; var top,left,width,height,nLabels,i,tvloc:integer; begin nLabels:=16; SetFontSize(12); SetFont('Helvetica'); SetText('Right Justified'); DrawScale; GetRoi(left,top,width,height); KillRoi; SetForeground(255); {black} SetBackground(0); {255} vloc:=top; for i:=1 to nLabels do begin MoveTo(left+width+25,vloc+3); tvloc:=vloc; if tvloc>(top+height-1) then tvloc:=Top+height-1; Writeln(GetPixel(left,tvloc)); vloc:=vloc+round(height/(nLabels-1)); end; end; procedure DoColorScaleDemo; var PicWidth,PicHeight,hloc,vloc,ScaleWidth,ScaleHeight:integer; begin GetPicSize(PicWidth,PicHeight); width:=0.1*PicWidth; if width>40 then width:=40; height:=0.9*PicHeight; hloc:=0.05*PicHeight; vloc:=hloc; SetPalette('Spectrum'); MakeRoi(hloc,vloc,width,height); DrawColorScale; wait(2); SetPalette('Grayscale'); end; procedure DemoFilters; var hloc,vloc,RoiWidth,RoiHeight,PicWidth,PicHeight:integer; begin MakeBlocks(3); RestoreRoi; GetRoi(hloc,vloc,RoiWidth,RoiHeight); GetPicSize(PicWidth,PicHeight); hloc:=0; vloc:=0; AdvanceRoi; SetOption; Sharpen; AdvanceRoi; Shadow; AdvanceRoi; TraceEdges; AdvanceRoi; SetOption; Smooth; TraceEdges; Skeletonize; AdvanceRoi; Dither; AdvanceRoi; Invert; AdvanceRoi; FlipVertical; AdvanceRoi; FlipHorizontal; end; procedure MakeGrayLevelGrid; var i,hloc,vloc,PicWidth,PicHeight:integer; RoiWidth,RoiHeight,GrayLevel,increment:integer; scale:real; begin n:=5; GetPicSize(PicWidth,PicHeight); hloc:=0; vloc:=0; RoiWidth:=PicWidth div n; RoiHeight:=PicHeight div n; MakeRoi(hloc,vloc,RoiWidth,RoiHeight); GrayLevel:=255; increment:=round(256/(n*n)); SetLineWidth(1); for i:=1 to n*n do begin SetForeground(GrayLevel); fill; SetForeground(0); DrawBoundary; GrayLevel:=GrayLevel-increment; if GrayLevel<0 then GrayLevel:=0; AdvanceRoi; end; KillRoi; end; macro 'Demo Macro [D]' { This macro demonstrate many of the features available in Image's macro language. It assumes the Image at least as large as`256x256 has been opened. } var i:integer; width,height,n,W,H:integer; scale:real; NoImage:boolean; StartTicks,time:real; begin StartTicks:=TickCount; NoImage:=nPics<>1; if not NoImage then GetPicSize(width,height); if NoImage or (width<256) or (height<256) then begin PutMessage('This macro needs a single image at least 256 pixels wide and 256 pixels high to operate on.'); Exit; end; SaveState; DemoFilters; wait(2); RevertToSaved; MakeGrayLevelGrid; wait(1); RevertToSaved; DrawGrayLevelScale(12); wait(1); RevertToSaved; DoColorScaleDemo; DoTextDemo; RevertToSaved; SetScaling('Nearest Neighbor; Same Window'); for i:= 1 to 4 do begin ScaleAndRotate(1.5,1.5,0); wait(.5); end; RevertToSaved; for i:=1 to 6 do begin ScaleAndRotate(0.6,0.6,0); wait(.5); RestoreRoi; end; RevertToSaved; wait(.5); ScaleAndRotate(.333,1,0); wait(1); Undo; ScaleAndRotate(1,.333,0); wait(1); Undo; FlipVertical; wait(.5); Undo; FlipHorizontal; wait(.5); Undo; RotateRight(true); RotateLeft(true); Shadow; Wait(1); Undo; Duplicate('Temp'); Smooth; for i:=1 to 3 do begin SetOption; Sharpen end; wait(.5); Dispose; SelectPic(1); Dither; wait(.5); Undo; AddConstant(100); Wait(1); Undo; AddConstant(-100); Wait(1); EnhanceContrast; Wait(.5); Undo; EqualizeHistogram; Wait(.5); ResetGraymap; ShowHistogram; Smooth; TraceEdges; wait(.5); Erode; Dilate; Outline; Undo; Skeletonize; Wait(1); for i:= 1 to 12 do TraceEdges; RestoreState; time:=(TickCount-StartTicks)/60; ShowMessage('time=',time:1:2,' seconds'); end; macro 'Make WallpaperÉ [M]' var width,height,n:integer; begin GetPicSize(width,height); if (width=0) then begin PutMessage('This macro needs an image to operate on.'); Exit; end; n:=trunc(GetNumber('Replication factor:',8)); SaveState; MakeBlocks(n); RestoreState; end;